diff --git a/.config/Sublime Text/Packages/User/Preferences.sublime-settings b/.config/Sublime Text/Packages/User/Preferences.sublime-settings index f1d475d..0f7d8e1 100644 --- a/.config/Sublime Text/Packages/User/Preferences.sublime-settings +++ b/.config/Sublime Text/Packages/User/Preferences.sublime-settings @@ -3,7 +3,7 @@ "caret_extra_top": 0, "caret_extra_width": 1, "font_size": 16, - "color_scheme": "Monokai.sublime-color-scheme", + "color_scheme": "Packages/User/massimo_custom.tmTheme", "translate_tabs_to_spaces": true, "tab_size": 4, "word_wrap": false, diff --git a/.emacs.d/init.el b/.emacs.d/init.el index 03441f9..6b90738 100755 --- a/.emacs.d/init.el +++ b/.emacs.d/init.el @@ -15,6 +15,25 @@ (require 'stupid-indent-mode) (require 'xah-find) (require 'multiple-cursors) +(require 'ivy) +(require 'counsel) +(require 's) +(require 'dash) +(require 'popup) +(require 'dumb-jump) +(setq dumb-jump-force-searcher 'grep) +(add-hook 'xref-backend-functions #'dumb-jump-xref-activate) +(setq xref-show-definitions-function #'xref-show-definitions-completing-read) + +;; undo-tree for persistent undo/redo +(require 'queue) +(require 'undo-tree) +(global-undo-tree-mode) +(setq undo-tree-history-directory-alist '(("." . "~/.emacs.d/undo-tree-history/"))) +(setq undo-tree-auto-save-history t) +(ivy-mode 1) +(setq ivy-use-virtual-buffers t) +(setq ivy-count-format "(%d/%d) ") ;; default indentation settings (setq-default indent-tabs-mode t) @@ -52,8 +71,130 @@ ;; general settings (setq-default inhibit-startup-screen t) -(add-to-list 'default-frame-alist '(width . 200)) -(add-to-list 'default-frame-alist '(height . 75)) + +;; bottom panel settings (compilation, xref, etc.) +(setq compilation-scroll-output t) + +;; bottom panel buffer patterns +(defvar my-bottom-panel-buffers '("\\*compilation\\*" "\\*xref\\*" "\\*terminal") + "List of buffer name patterns for bottom panel.") + +(defun my-bottom-panel-buffer-p (buf) + "Check if BUF is a bottom panel buffer." + (seq-some (lambda (pat) (string-match-p pat (buffer-name buf))) + my-bottom-panel-buffers)) + +;; find existing bottom panel window +(defun my-get-bottom-panel-window () + "Get existing bottom panel window if any." + (seq-find (lambda (w) + (and (window-at-side-p w 'bottom) + (my-bottom-panel-buffer-p (window-buffer w)))) + (window-list))) + +;; display function that reuses bottom panel +(defun my-display-in-bottom-panel (buffer alist) + "Display BUFFER in bottom panel, reusing existing panel window." + (let ((window (my-get-bottom-panel-window))) + (if window + (progn + (set-window-buffer window buffer) + window) + (let ((new-window (display-buffer-at-bottom buffer alist))) + (when new-window + (with-selected-window new-window + (set-window-parameter new-window 'window-height 0.25))) + new-window)))) + +;; use our custom display function for panel buffers +(add-to-list 'display-buffer-alist + '("\\*compilation\\*" (my-display-in-bottom-panel) (window-height . 0.25))) +(add-to-list 'display-buffer-alist + '("\\*xref\\*" (my-display-in-bottom-panel) (window-height . 0.25))) + +;; tab line for bottom panel +(defun my-bottom-panel-tab-line () + "Return tab line tabs for bottom panel buffers." + (seq-filter #'my-bottom-panel-buffer-p (buffer-list))) + +(defun my-enable-bottom-panel-tabs () + "Enable tab-line-mode for bottom panel buffers." + (setq-local tab-line-tabs-function #'my-bottom-panel-tab-line) + (tab-line-mode 1)) + +(add-hook 'compilation-mode-hook #'my-enable-bottom-panel-tabs) +(add-hook 'xref--xref-buffer-mode-hook #'my-enable-bottom-panel-tabs) +(add-hook 'term-mode-hook #'my-enable-bottom-panel-tabs) + +(defvar my-terminal-counter 0 "Counter for terminal instances.") + +(defun my-get-shell () + "Get the shell program for the current platform." + (cond ((eq system-type 'darwin) "/bin/zsh") + ((eq system-type 'gnu/linux) "/bin/bash") + ((eq system-type 'windows-nt) "powershell") + (t "/bin/sh"))) + +(defun my-open-terminal () + "Open first terminal in bottom panel, or create one if none exist." + (interactive) + (let ((existing (seq-find (lambda (buf) + (string-match-p "\\*terminal" (buffer-name buf))) + (buffer-list)))) + (if existing + (let ((win (my-display-in-bottom-panel existing '((window-height . 0.25))))) + (when win (select-window win))) + (my-open-terminal-new)))) + +(defun my-open-terminal-new () + "Open a new terminal instance in bottom panel." + (interactive) + (let* ((default-directory (or (and (project-current) + (project-root (project-current))) + default-directory)) + (name (format "terminal-%d" (setq my-terminal-counter (1+ my-terminal-counter)))) + (buf (make-term name (my-get-shell)))) + (with-current-buffer buf + (term-mode) + (term-char-mode)) + (let ((win (my-display-in-bottom-panel buf '((window-height . 0.25))))) + (when win (select-window win))))) + +(defun my-bottom-panel-toggle () + "Toggle the bottom panel. Close if visible, open if hidden." + (interactive) + (let ((panel-window (my-get-bottom-panel-window))) + (if panel-window + (delete-window panel-window) + (let ((matching-buffers (seq-filter + (lambda (buf) + (seq-some (lambda (pat) (string-match-p pat (buffer-name buf))) + my-bottom-panel-buffers)) + (buffer-list)))) + (if matching-buffers + (let ((win (my-display-in-bottom-panel (car matching-buffers) '((window-height . 0.25))))) + (when (and win (string-match-p "\\*terminal" (buffer-name (car matching-buffers)))) + (select-window win))) + (message "No bottom panel buffers open.")))))) + +(defun my-bottom-panel-next () + "Cycle to next bottom panel buffer in bottom window." + (interactive) + (let* ((matching-buffers (seq-filter + (lambda (buf) + (seq-some (lambda (pat) (string-match-p pat (buffer-name buf))) + my-bottom-panel-buffers)) + (buffer-list))) + (bottom-window (seq-find (lambda (w) (window-at-side-p w 'bottom)) (window-list))) + (current (and bottom-window (window-buffer bottom-window))) + (idx (and current (seq-position matching-buffers current)))) + (if (and matching-buffers bottom-window) + (let ((next-buf (if idx + (nth (mod (1+ idx) (length matching-buffers)) matching-buffers) + (car matching-buffers)))) + (set-window-buffer bottom-window next-buf)) + (message "No bottom panel buffers open.")))) +(add-to-list 'default-frame-alist '(fullscreen . maximized)) (show-paren-mode 1) (delete-selection-mode 1) (setq cua-auto-tabify-rectangles nil) ;; Don't tabify after rectangle commands @@ -84,6 +225,7 @@ (setq custom-file "~/.emacs.d/custom.el") ;; place custom in a separate file (setq-default require-final-newline t) (cua-mode t) +(global-hl-line-mode -1) ;; backup and autosave settings (setq backup-by-copying t ; don't clobber symlinks @@ -96,22 +238,52 @@ `((".*" "~/.emacs.d/saves/" t))) (setq create-lockfiles nil) +;; Recursively kill process and all descendants +(defun my-kill-process-tree (pid) + "Kill PID and all its descendant processes." + (let ((children (split-string + (shell-command-to-string + (format "pgrep -P %d 2>/dev/null" pid)) + "\n" t))) + (dolist (child children) + (when (string-match "^[0-9]+$" child) + (my-kill-process-tree (string-to-number child))))) + (ignore-errors (call-process "kill" nil nil nil "-9" (number-to-string pid)))) + +;; Ensure all subprocesses (including grandchildren like DLV) are killed when Emacs exits +(add-hook 'kill-emacs-hook + (lambda () + (dolist (proc (process-list)) + (when (process-live-p proc) + (let ((pid (process-id proc))) + (when pid + (my-kill-process-tree pid))) + (set-process-query-on-exit-flag proc nil) + (ignore-errors (delete-process proc)))))) + ;; Keybindings / Keybinds ;; global (global-set-key (kbd "C-a") 'mark-whole-buffer) +(global-set-key (kbd "C-n") (lambda () (interactive) (switch-to-buffer (generate-new-buffer "untitled")))) (global-set-key (kbd "S-") #'my-mouse-start-rectangle) -(global-set-key (kbd "") 'revert-buffer-quick) +(global-set-key (kbd "") 'my-compile-last) +(global-set-key (kbd "") 'my-compile-custom) +(global-set-key (kbd "") 'my-bottom-panel-toggle) +(global-set-key (kbd "") 'my-bottom-panel-next) +(global-set-key (kbd "C-`") 'my-open-terminal) +(global-set-key (kbd "C-~") 'my-open-terminal-new) (global-set-key (kbd "") 'my-file-manager-command) +(global-set-key (kbd "") 'project-switch-project) (global-set-key (kbd "") 'my-terminal-emulator-command) (global-set-key [f8] 'goto-line) -(global-set-key (kbd "C-\\") 'split-window-below) -(global-set-key (kbd "C-|") 'split-window-right) +(global-set-key (kbd "C-\\") 'delete-other-windows) +(global-set-key (kbd "C-|") 'kill-all-buffers) (global-unset-key (kbd "C-x C-SPC")) (global-set-key (kbd "C-x C-SPC") 'rectangle-mark-mode) (global-set-key [C-return] 'save-buffer) (global-set-key [?\C-z] 'undo) (global-set-key (kbd "C-*") 'search-current-word) -(global-set-key (kbd "C-;") 'comment-line) +(global-set-key (kbd "C-/") 'comment-line) (global-set-key (kbd "M-") 'save-buffers-kill-terminal) ;; windows thing (global-set-key (kbd "C-y") 'clipboard-yank) ;; fix killring messing with system clipboard (global-set-key (kbd "C-w") 'delete-window) @@ -124,20 +296,64 @@ (global-set-key (kbd "") 'move-end-of-line) (setq mac-command-modifier 'control) (setq mac-control-modifier 'command) + +;; Restore normal cmd/ctrl in terminal buffers on macOS +(when (eq system-type 'darwin) + (add-hook 'term-mode-hook + (lambda () + (setq-local mac-command-modifier 'super) + (setq-local mac-control-modifier 'control)))) + +;; Enable paste in terminal (Cmd-v on macOS, C-S-v elsewhere) +(add-hook 'term-mode-hook + (lambda () + (if (eq system-type 'darwin) + (define-key term-raw-map (kbd "s-v") 'term-paste) + (define-key term-raw-map (kbd "C-S-v") 'term-paste)))) + +;; F5 in terminal: Ctrl-C, rebuild, enter, r, enter, c, enter +(defun my-term-rebuild () + "Send rebuild sequence to terminal." + (interactive) + (term-send-raw-string "\C-c") + (sit-for 0.1) + (term-send-raw-string "rebuild\r") + (sit-for 0.1) + (term-send-raw-string "r\r") + (sit-for 0.1) + (term-send-raw-string "c\r")) + +(add-hook 'term-mode-hook + (lambda () + (define-key term-raw-map (kbd "") 'my-term-rebuild))) + +;; Kill terminal buffer when process exits +(defun my-term-handle-exit (&optional process-name msg) + "Kill terminal buffer when process exits." + (when (buffer-live-p (current-buffer)) + (kill-buffer (current-buffer)))) + +(advice-add 'term-handle-exit :after #'my-term-handle-exit) (when (eq system-type 'darwin) (global-set-key (kbd "C-") 'my-smart-home) (global-set-key (kbd "C-") 'move-end-of-line)) (global-set-key (kbd "C-f") 'my-isearch-forward) -(global-set-key (kbd "C-S-f") 'xah-find-text) +(global-set-key (kbd "C-S-f") 'my-project-find-text) +(global-set-key (kbd "C-S-h") 'my-find-replace) +(global-set-key (kbd "C-S-p") 'counsel-M-x) +(global-set-key (kbd "C-p") 'project-find-file) (global-set-key (kbd "C-s") 'save-buffer) -(global-set-key (kbd "") 'my-toggle-theme) -(global-set-key (kbd "") (lambda () (interactive) (load-file user-init-file))) +(global-set-key (kbd "") 'my-select-theme) +(global-set-key (kbd "") 'xref-find-definitions) +(global-set-key (kbd "") 'xref-pop-marker-stack) (global-set-key (kbd "C-q") 'save-buffers-kill-terminal) (global-set-key (kbd "C-l") 'my-select-line) +(global-set-key (kbd "C-e") 'my-copy-path-with-line) (define-key minibuffer-local-filename-completion-map (kbd "C-2") 'my-find-file-right-pane) (define-key isearch-mode-map (kbd "") 'isearch-repeat-forward) (define-key isearch-mode-map (kbd "S-") 'isearch-repeat-backward) (define-key isearch-mode-map (kbd "") 'isearch-del-char) +(define-key isearch-mode-map (kbd "") 'isearch-exit) (setq isearch-wrap-pause 'no) ;; multiple cursors (vscode-style) @@ -151,6 +367,34 @@ (define-key mc/keymap (kbd "") 'mc/keyboard-quit) (define-key mc/keymap (kbd "") nil) +;; functions to get top panes (ignoring bottom compilation window) +(defun my-get-top-windows () + "Get windows in the top portion of the frame (not bottom compilation)." + (let ((windows '())) + (walk-windows + (lambda (w) + (when (window-at-side-p w 'top) + (push w windows)))) + (sort windows (lambda (a b) (< (car (window-edges a)) (car (window-edges b))))))) + +(defun my-select-left-pane () + "Select the left pane of the top split." + (interactive) + (let ((top-windows (my-get-top-windows))) + (when top-windows + (select-window (car top-windows))))) + +(defun my-select-right-pane () + "Select the right pane of the top split, creating it if needed." + (interactive) + (let ((top-windows (my-get-top-windows))) + (if (>= (length top-windows) 2) + (select-window (cadr top-windows)) + (when top-windows + (select-window (car top-windows)) + (split-window-right) + (other-window 1))))) + ;; custom bind minor mode ;; this allows binding keys that override all other modes (defvar my-keys-minor-mode-map @@ -158,11 +402,8 @@ (define-key map (kbd "M-p") 'backward-paragraph) (define-key map (kbd "M-n") 'forward-paragraph) (define-key map (kbd "C-o") 'next-multiframe-window) - (define-key map (kbd "C-1") (lambda () (interactive) (select-window (frame-first-window)))) - (define-key map (kbd "C-2") (lambda () (interactive) - (if (one-window-p) - (progn (split-window-right) (other-window 1)) - (other-window 1)))) + (define-key map (kbd "C-1") 'my-select-left-pane) + (define-key map (kbd "C-2") 'my-select-right-pane) (define-key map (kbd "C-3") 'switch-to-buffer) (define-key map (kbd "C-4") 'find-file) (define-key map (kbd "C-j") 'dabbrev-expand) @@ -192,6 +433,91 @@ (when (= orig-point (point)) (move-beginning-of-line 1)))) +;; project find text (literal search) +(defun my-project-find-text () + "Search for literal text in project." + (interactive) + (let ((text (read-string "Search in project: "))) + (project-find-regexp (regexp-quote text)))) + +(defun my-project-find-word-at-point () + "Search for word under cursor in project." + (interactive) + (let ($p1 $p2 word) + (if (region-active-p) + (setq $p1 (region-beginning) $p2 (region-end)) + (save-excursion + (skip-chars-backward "-_A-Za-z0-9") + (setq $p1 (point)) + (skip-chars-forward "-_A-Za-z0-9") + (setq $p2 (point)))) + (setq word (buffer-substring-no-properties $p1 $p2)) + (when (> (length word) 0) + (project-find-regexp (regexp-quote word))))) + +;; compile custom command (persisted per-project) +(defvar my-project-data-dir "~/.emacs.d/project-data/" "Directory to store per-project data.") + +(defun my-project-data-file (filename) + "Get path to FILENAME for current project in project-data dir." + (let* ((root (project-root (project-current t))) + (hash (md5 root)) + (dir (expand-file-name hash my-project-data-dir))) + (unless (file-exists-p dir) + (make-directory dir t)) + (expand-file-name filename dir))) + +(defun my-compile-get-saved-command () + "Get saved compile command for current project." + (let ((file (my-project-data-file "compile-command"))) + (when (file-exists-p file) + (with-temp-buffer + (insert-file-contents file) + (string-trim (buffer-string)))))) + +(defun my-compile-save-command (cmd) + "Save compile command CMD for current project." + (let ((file (my-project-data-file "compile-command"))) + (with-temp-file file + (insert cmd)))) + +(defun my-compile-custom () + "Run a custom compile command in the project root." + (interactive) + (let* ((default-directory (project-root (project-current t))) + (saved (my-compile-get-saved-command)) + (cmd (read-string "Command: " saved))) + (my-compile-save-command cmd) + (compile cmd))) + +(defun my-compile-last () + "Run last compile command, or prompt for one if none has been run." + (interactive) + (let* ((default-directory (project-root (project-current t))) + (cmd (my-compile-get-saved-command))) + (if cmd + (compile cmd) + (my-compile-custom)))) + +;; find and replace with modes +(defun my-find-replace () + "Find and replace with mode selection: project, file, or selection." + (interactive) + (let* ((mode (completing-read "Replace in: " '("file" "project" "selection") nil t)) + (search (read-string "Find: ")) + (replace (read-string (format "Replace '%s' with: " search)))) + (cond + ((string= mode "project") + (project-query-replace-regexp (regexp-quote search) replace)) + ((string= mode "file") + (save-excursion + (goto-char (point-min)) + (query-replace search replace))) + ((string= mode "selection") + (if (use-region-p) + (query-replace search replace nil (region-beginning) (region-end)) + (message "No region selected.")))))) + ;; isearch with selection (vscode-style) (defun my-isearch-forward () "Start isearch, using selected text if region is active." @@ -236,37 +562,19 @@ (add-hook 'minibuffer-exit-hook 'my-find-file-right-pane-after) -;; theme toggle (dark/light) -(defvar my-dark-theme-p t "Non-nil if dark theme is active.") +;; theme selection +(add-to-list 'custom-theme-load-path "~/.emacs.d/themes/") +(defvar my-current-theme 'bedroom "Currently active theme.") -(defun my-set-dark-theme () - "Apply dark color theme." - (set-face-attribute 'default nil :foreground "#d3b58d" :background "#181E2C") - (set-face-attribute 'font-lock-comment-face nil :foreground "#bf9319") - (set-face-attribute 'font-lock-string-face nil :foreground "#8fcddb") - (set-face-attribute 'font-lock-keyword-face nil :foreground "white") - (set-face-attribute 'font-lock-function-name-face nil :foreground "white") - (set-face-attribute 'font-lock-variable-name-face nil :foreground "#c8d4ec") - (set-face-attribute 'region nil :background "blue") - (set-cursor-color "lightgreen")) - -(defun my-set-light-theme () - "Apply light color theme." - (set-face-attribute 'default nil :foreground "#2E3440" :background "honeydew") - (set-face-attribute 'font-lock-comment-face nil :foreground "#8B7355") - (set-face-attribute 'font-lock-string-face nil :foreground "#2E8B57") - (set-face-attribute 'font-lock-keyword-face nil :foreground "#0000CD") - (set-face-attribute 'font-lock-function-name-face nil :foreground "#8B0000") - (set-face-attribute 'font-lock-variable-name-face nil :foreground "#483D8B") - (set-face-attribute 'region nil :background "#ADD8E6") - (set-cursor-color "black")) - -(defun my-toggle-theme () - "Toggle between dark and light themes." +(defun my-select-theme () + "Select and load a theme from all available themes." (interactive) - (if my-dark-theme-p - (progn (my-set-light-theme) (setq my-dark-theme-p nil)) - (my-set-dark-theme) (setq my-dark-theme-p t))) + (let* ((themes (mapcar #'symbol-name (custom-available-themes))) + (choice (completing-read "Theme: " themes nil t))) + (when my-current-theme + (disable-theme my-current-theme)) + (setq my-current-theme (intern choice)) + (load-theme my-current-theme t))) ;; global zoom (without resizing window) (setq frame-inhibit-implied-resize t) @@ -290,6 +598,8 @@ (global-unset-key (kbd "C-x C-=")) (global-unset-key (kbd "C-x C--")) (global-unset-key (kbd "C-x C-0")) +(global-set-key (kbd "C-") 'ignore) +(global-set-key (kbd "C-") 'ignore) ;; test function (defun my-test () @@ -319,6 +629,65 @@ ) (next-line arg)) +;; kill all buffers except current and close other panes +(defun kill-all-buffers () + "Kill all buffers except the current one and close other panes." + (interactive) + (let ((current (current-buffer))) + (mapc (lambda (buf) + (unless (eq buf current) + (kill-buffer buf))) + (buffer-list))) + (delete-other-windows)) + +;; delete word without copying to kill ring +(defun my-delete-word (arg) + "Delete characters forward until encountering the end of a word. +With argument ARG, do this that many times. +Does not copy to kill ring." + (interactive "p") + (delete-region (point) (progn (forward-word arg) (point)))) + +(defun my-backward-delete-word (arg) + "Delete characters backward until encountering the beginning of a word. +With argument ARG, do this that many times. +Does not copy to kill ring." + (interactive "p") + (my-delete-word (- arg))) + +(global-set-key (kbd "M-") 'my-backward-delete-word) +(global-set-key (kbd "M-d") 'my-delete-word) +(global-set-key (kbd "C-") 'my-backward-delete-word) + +;; copy current path with line number +(defun my-copy-path-with-line () + "Copy the current file path with line number to clipboard." + (interactive) + (if buffer-file-name + (let ((path-with-line (format "%s:%d" buffer-file-name (line-number-at-pos)))) + (kill-new path-with-line) + (message "Copied: %s" path-with-line)) + (message "Buffer has no file."))) + +;; scratch buffer with recent projects +(defvar my-dashboard-image "~/.emacs.d/logo.jpg" + "Path to dashboard image.") + +(defun my-setup-scratch-buffer () + "Setup scratch buffer." + (with-current-buffer (get-buffer-create "*scratch*") + (let ((inhibit-read-only t)) + (erase-buffer) + (insert "\n") + ;; Image + (when (and (display-graphic-p) + (file-exists-p (expand-file-name my-dashboard-image))) + (insert-image (create-image (expand-file-name my-dashboard-image) nil nil :height 150)) + (insert "\n\n")) + ;; Message + (insert "Agartha needs your help! You must write a new operating system from scratch to restore Agartha's defences!\n\nYou will need some food, water, and a funny hat to complete this mission!\n") + (goto-char (point-min))))) + ;; select rectangle with shift+mouse (defun my-mouse-start-rectangle (start-event) (interactive "e") @@ -410,18 +779,8 @@ Use in `isearch-mode-end-hook'." ;; appearance ;; (set-face-attribute 'default nil :font "Consolas-15") -;; non-theme-specific face customizations -(custom-set-faces - '(custom-group-tag-face ((t (:underline t :foreground "lightblue"))) t) - '(custom-variable-tag-face ((t (:underline t :foreground "lightblue"))) t) - '(font-lock-builtin-face ((t nil))) - '(font-lock-warning-face ((t (:foreground "#504038")))) - '(highlight ((t (:foreground "navyblue" :background "darkseagreen2")))) - '(mode-line ((t (:inverse-video t)))) - '(widget-field-face ((t (:foreground "white"))) t) - '(widget-single-line-field-face ((t (:background "darkgray"))) t)) - -(add-to-list 'default-frame-alist '(cursor-color . "lightgreen")) - (global-font-lock-mode 1) -(my-set-dark-theme) +(load-theme 'bedroom t) + +;; setup scratch buffer with recent projects on startup +(add-hook 'emacs-startup-hook 'my-setup-scratch-buffer) diff --git a/.emacs.d/lisp/colir.el b/.emacs.d/lisp/colir.el new file mode 100644 index 0000000..a06e495 --- /dev/null +++ b/.emacs.d/lisp/colir.el @@ -0,0 +1,130 @@ +;;; colir.el --- Color blending library -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2025 Free Software Foundation, Inc. + +;; Author: Oleh Krehel + +;; This file is part of GNU Emacs. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; For a full copy of the GNU General Public License +;; see . + +;;; Commentary: + +;; This package solves the problem of adding a face with a background +;; to text which may already have a background. In all conflicting +;; areas, instead of choosing either the original or the new +;; background face, their blended sum is used. +;; +;; The blend mode functions are taken from URL +;; `https://en.wikipedia.org/wiki/Blend_modes'. + +;;; Code: + +(require 'cl-lib) + +(eval-and-compile + ;; Autoloaded since Emacs 31. + (unless (fboundp 'color-rgb-to-hex) + (autoload 'color-rgb-to-hex "color"))) + +(defcustom colir-compose-method #'colir-compose-alpha + "The method `colir-blend' uses to compose two color channels." + :group 'ivy + :type '(radio + (function-item colir-compose-alpha) + (function-item colir-compose-overlay) + (function-item colir-compose-soft-light))) + +(defun colir-compose-soft-light (a b) + "Compose color channels A and B in Soft Light blend mode. +See URL `https://en.wikipedia.org/wiki/Blend_modes#Soft_Light'." + (if (< b 0.5) + (+ (* 2 a b) (* a a (- 1 b b))) + (+ (* 2 a (- 1 b)) (* (sqrt a) (+ b b -1))))) + +(defun colir-compose-overlay (a b) + "Compose color channels A and B in Overlay blend mode. +See URL `https://en.wikipedia.org/wiki/Blend_modes#Overlay'." + (if (< a 0.5) + (* 2 a b) + (- 1 (* 2 (- 1 a) (- 1 b))))) + +;; Generalizes Emacs 31 `color-blend'. +(defun colir-compose-alpha (a b &optional alpha gamma) + "Compose color channels A and B using alpha blending. +Optional argument ALPHA controls the influence of A on the result. +It is a number between 0.0 and 1.0, inclusive (default 0.5). +Optional argument GAMMA controls gamma correction (default 2.2)." + (setq alpha (or alpha 0.5)) + (setq gamma (or gamma 2.2)) + (+ (* (expt a gamma) alpha) (* (expt b gamma) (- 1 alpha)))) + +(defun colir-blend (c1 c2) + "Blend the two colors C1 and C2 using `colir-compose-method'. +C1 and C2 are triples of floats in [0.0 1.0] range." + (apply #'color-rgb-to-hex + (cl-mapcar + (if (eq (frame-parameter nil 'background-mode) 'dark) + ;; This method works nicely for dark themes. + #'colir-compose-soft-light + colir-compose-method) + c1 c2))) + +(defun colir-color-parse (color) + "Convert string COLOR to triple of floats in [0.0 1.0]." + (if (string-match "#\\([[:xdigit:]]\\{2\\}\\)\\([[:xdigit:]]\\{2\\}\\)\\([[:xdigit:]]\\{2\\}\\)" color) + (mapcar (lambda (v) (/ (string-to-number v 16) 255.0)) + (list (match-string 1 color) (match-string 2 color) (match-string 3 color))) + ;; does not work properly in terminal (maps color to nearest color + ;; from available color palette). + (color-name-to-rgb color))) + +(defun colir--blend-background (start next prevn face object) + (let ((background-prev (face-background prevn))) + (put-text-property + start next 'face + (if background-prev + (cons `(background-color + . ,(colir-blend + (colir-color-parse background-prev) + (colir-color-parse (face-background face nil t)))) + prevn) + (list face prevn)) + object))) + +(defun colir-blend-face-background (start end face &optional object) + "Append to the face property of the text from START to END the face FACE. +When the text already has a face with a non-plain background, +blend it with the background of FACE. +Optional argument OBJECT is the string or buffer containing the text. +See also `font-lock-append-text-property'." + (let (next prev prevn) + (while (/= start end) + (setq next (next-single-property-change start 'face object end)) + (setq prev (get-text-property start 'face object)) + (setq prevn (if (listp prev) + (cl-find-if #'atom prev) + prev)) + (cond + ((or (keywordp (car-safe prev)) (consp (car-safe prev))) + (put-text-property start next 'face (cons face prev) object)) + ((facep prevn) + (colir--blend-background start next prevn face object)) + (t + (put-text-property start next 'face face object))) + (setq start next)))) + +(provide 'colir) + +;;; colir.el ends here diff --git a/.emacs.d/lisp/counsel.el b/.emacs.d/lisp/counsel.el new file mode 100644 index 0000000..9aa7f1c --- /dev/null +++ b/.emacs.d/lisp/counsel.el @@ -0,0 +1,7398 @@ +;;; counsel.el --- Various completion functions using Ivy -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2025 Free Software Foundation, Inc. + +;; Author: Oleh Krehel +;; Maintainer: Basil L. Contovounesios +;; URL: https://github.com/abo-abo/swiper +;; Version: 0.15.1 +;; Package-Requires: ((emacs "24.5") (ivy "0.15.1") (swiper "0.15.1")) +;; Keywords: convenience, matching, tools + +;; This file is part of GNU Emacs. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; For a full copy of the GNU General Public License +;; see . + +;;; Commentary: + +;; Just call one of the interactive functions in this file to complete +;; the corresponding thing using `ivy'. +;; +;; Currently available: +;; - Symbol completion for Elisp, Common Lisp, Python, Clojure, C, C++. +;; - Describe functions for Elisp: function, variable, library, command, +;; bindings, theme. +;; - Navigation functions: imenu, ace-line, semantic, outline. +;; - Git utilities: git-files, git-grep, git-log, git-stash, git-checkout. +;; - Grep utilities: grep, ag, pt, recoll, ack, rg. +;; - System utilities: process list, rhythmbox, linux-app. +;; - Many more. + +;;; Code: + +(require 'ivy) +(require 'swiper) + +(eval-when-compile + (require 'subr-x)) + +(eval-when-compile + (unless (fboundp 'static-if) + (defmacro static-if (condition then-form &rest else-forms) + "Expand to THEN-FORM or ELSE-FORMS based on compile-time CONDITION. +Polyfill for Emacs 30 `static-if'." + (declare (debug (sexp sexp &rest sexp)) (indent 2)) + (if (eval condition lexical-binding) + then-form + (macroexp-progn else-forms))))) + +(defgroup counsel nil + "Completion functions using Ivy." + :group 'matching + :prefix "counsel-") + +;;; Utility + +(defun counsel--elisp-to-pcre (regex &optional look-around) + "Convert REGEX from Elisp format to PCRE format, on best-effort basis. +REGEX may be of any format returned by an Ivy regex function, +namely a string or a list. The return value is always a string. + +Note that incorrect results may be returned for sufficiently +complex regexes." + (if (consp regex) + (if (and look-around + (or (cdr regex) + (not (cdar regex)))) + (concat + "^" + (mapconcat + (lambda (pair) + (let ((subexp (counsel--elisp-to-pcre (car pair)))) + (format "(?%c.*%s)" + (if (cdr pair) ?= ?!) + subexp))) + regex + "")) + (mapconcat + (lambda (pair) + (let ((subexp (counsel--elisp-to-pcre (car pair)))) + (if (ivy--string-search "|" subexp) + (format "(?:%s)" subexp) + subexp))) + (cl-remove-if-not #'cdr regex) + ".*")) + (replace-regexp-in-string + "\\\\[(){}|`']\\|[()]" + (lambda (s) + (or (cdr (assoc s '(("\\(" . "(") + ("\\)" . ")") + ("(" . "\\(") + (")" . "\\)") + ("\\{" . "{") + ("\\}" . "}") + ("\\|" . "|") + ("\\`" . "^") + ("\\'" . "$")))) + (error + "Unexpected error in `counsel--elisp-to-pcre' (got match %S)" s))) + regex t t))) + +(defun counsel-directory-name (dir) + "Return the name of directory DIR with a slash." + (file-name-as-directory + (file-name-nondirectory + (directory-file-name dir)))) + +(defun counsel-string-compose (prefix str) + "Make PREFIX the display prefix of STR through text properties." + (let ((str (copy-sequence str))) + (put-text-property + 0 1 'display + (concat prefix (substring str 0 1)) + str) + str)) + +(defalias 'counsel--executable-find + ;; Gained optional argument in 27.1. + (if (>= emacs-major-version 27) + #'executable-find + (lambda (command &optional _remote) + (executable-find command))) + "Compatibility shim for `executable-find'.") + +(defun counsel-require-program (cmd &optional noerror) + "Check system for program used in CMD, printing error if not found. +CMD is either a string or a list of strings. +To skip the `executable-find' check, start the string with a space. +When NOERROR is non-nil, return nil instead of raising an error." + (unless (and (stringp cmd) (string-prefix-p " " cmd)) + (let ((program (if (listp cmd) + (car cmd) + (car (split-string cmd))))) + (or (and (stringp program) + (not (string= program "")) + (counsel--executable-find program t)) + (unless noerror + (user-error "Required program \"%s\" not found in your path" program)))))) + +(defun counsel-prompt-function-dir () + "Return prompt appended with the parent directory." + (declare (obsolete "it is no longer used." "0.15.1")) + (require 'esh-util) + (let* ((dir (ivy-state-directory ivy-last)) + (parts (nthcdr 3 (funcall (if (fboundp 'eshell-split-filename) + ;; New name since Emacs 30. + #'eshell-split-filename + 'eshell-split-path) + dir))) + (dir (format " [%s]: " (if parts (apply #'concat "..." parts) dir)))) + (ivy-add-prompt-count + (replace-regexp-in-string ; Insert dir before any trailing colon. + "\\(?:: ?\\)?\\'" dir (ivy-state-prompt ivy-last) t t)))) + +(defalias 'counsel--flatten + ;; Added in Emacs 27.1 + (if (fboundp 'flatten-tree) + #'flatten-tree + (lambda (tree) + (let (elems) + (while (consp tree) + (let ((elem (pop tree))) + (while (consp elem) + (push (cdr elem) tree) + (setq elem (car elem))) + (if elem (push elem elems)))) + (if tree (push tree elems)) + (nreverse elems)))) + "Compatibility shim for `flatten-tree'.") + +(defun counsel--format (formatter &rest args) + "Like `format' but FORMATTER can be a list. +When FORMATTER is a list, only `%s' is replaced with ARGS. + +Return a list or string depending on input." + (cond + ((listp formatter) + (counsel--flatten (mapcar + (lambda (it) (if (equal it "%s") (pop args) it)) + formatter))) + (t (apply #'format formatter args)))) + +(defalias 'counsel--null-device + (if (fboundp 'null-device) #'null-device (lambda () null-device)) + "Compatibility shim for Emacs 28 function `null-device'.") + +;;;; Async utility + +(defvar counsel--async-time nil + "Store the time when a new process was started. +Or the time of the last minibuffer update.") + +(defvar counsel--async-start nil + "Store the time when a new process was started.") + +(defvar counsel--async-timer nil + "Timer used to dispose `counsel--async-command.") + +(defvar counsel--async-duration nil + "Store the time a process takes to gather all its candidates. +The time is measured in seconds.") + +(defvar counsel--async-exit-code-plist () + "Associate commands with their exit code descriptions. +This plist maps commands to a plist mapping their exit codes to +descriptions.") + +(defvar counsel--async-last-error-string nil + "When the process returned non-0, store the output here.") + +(defun counsel-set-async-exit-code (cmd number str) + "For CMD, associate NUMBER exit code with STR." + (let ((plist (plist-get counsel--async-exit-code-plist cmd))) + (setq counsel--async-exit-code-plist + (plist-put counsel--async-exit-code-plist + cmd + (plist-put plist number str))))) + +(defvar counsel-async-split-string-re-alist '((t . "[\r\n]")) + "Store the regexp for splitting shell command output.") + +(defvar counsel-async-ignore-re-alist nil + "An alist of regexp matching candidates to ignore in `counsel--async-filter'.") + +(defvar counsel--async-last-command nil + "Store the last command ran by `counsel--async-command-1'.") + +(defun counsel--async-command-1 (cmd &optional sentinel filter name) + "Start and return new counsel process by calling CMD. +CMD can be either a shell command as a string, or a list of the +program name to be called directly, followed by its arguments. +If the default counsel process or one with NAME already exists, +kill it and its associated buffer before starting a new one. +Give the process the functions SENTINEL and FILTER, which default +to `counsel--async-sentinel' and `counsel--async-filter', +respectively." + (counsel-delete-process name) + (setq name (or name " *counsel*")) + (when (get-buffer name) + (kill-buffer name)) + (setq counsel--async-last-command cmd) + (let* ((buf (get-buffer-create name)) + (proc (if (listp cmd) + (apply #'start-file-process name buf cmd) + (start-file-process-shell-command name buf cmd)))) + (setq counsel--async-time (current-time)) + (setq counsel--async-start counsel--async-time) + (set-process-sentinel proc (or sentinel #'counsel--async-sentinel)) + (set-process-filter proc (or filter #'counsel--async-filter)) + proc)) + +(defcustom counsel-async-command-delay 0 + "Number of seconds to wait before spawning another async command." + :type 'number) + +(defun counsel--async-command (&rest args) + "Like `counsel--async-command-1', with same ARGS, but debounced. +Calls to `counsel--async-command-1' are separated by at least +`counsel-async-command-delay' seconds, so as to avoid issues +caused by spawning too many subprocesses too quickly." + (if (zerop counsel-async-command-delay) + (apply #'counsel--async-command-1 args) + (when counsel--async-timer + (cancel-timer counsel--async-timer)) + (setq counsel--async-timer + (apply #'run-with-timer + counsel-async-command-delay + nil + #'counsel--async-command-1 + args)))) + +(defun counsel--split-string (&optional str) + (split-string + (or str (buffer-string)) + (ivy-alist-setting counsel-async-split-string-re-alist) + t)) + +(defun counsel--sync-sentinel-on-exit (process) + (if (zerop (process-exit-status process)) + (let ((cur (ivy-state-current ivy-last))) + (ivy--set-candidates + (ivy--sort-maybe + (with-current-buffer (process-buffer process) + (counsel--split-string)))) + (when counsel--async-start + (setq counsel--async-duration + (time-to-seconds (time-since counsel--async-start)))) + (let ((re (ivy-re-to-str ivy-regex))) + (if ivy--old-cands + (if (eq (ivy-alist-setting ivy-index-functions-alist) 'ivy-recompute-index-zero) + (ivy-set-index 0) + (ivy--recompute-index re ivy--all-candidates)) + ;; index was changed before a long-running query exited + (unless (string= cur (nth ivy--index ivy--all-candidates)) + (let ((func (ivy-alist-setting ivy-index-functions-alist))) + (if func + (funcall func re ivy--all-candidates) + (ivy--preselect-index + (if (> (length re) 0) + cur + (ivy-state-preselect ivy-last)) + ivy--all-candidates)))))) + (setq ivy--old-cands ivy--all-candidates) + (if ivy--all-candidates + (ivy--exhibit) + (ivy--insert-minibuffer ""))) + (setq counsel--async-last-error-string + (with-current-buffer (process-buffer process) (buffer-string))) + (setq ivy--all-candidates + (let ((status (process-exit-status process)) + (plist (plist-get counsel--async-exit-code-plist + (ivy-state-caller ivy-last)))) + (list (or (plist-get plist status) + (format "error code %d" status))))) + (setq ivy--old-cands ivy--all-candidates) + (ivy--exhibit))) + +(defun counsel--async-sentinel (process _msg) + "Sentinel function for an asynchronous counsel PROCESS." + (when (eq (process-status process) 'exit) + (counsel--sync-sentinel-on-exit process))) + +(defcustom counsel-async-filter-update-time 500000 + "The amount of microseconds to wait until updating `counsel--async-filter'." + :type 'integer) + +(defalias 'counsel--async-filter-update-time + (if (fboundp 'time-convert) + ;; Preferred (TICKS . HZ) format since Emacs 27.1. + (lambda () (cons counsel-async-filter-update-time 1000000)) + (lambda () (list 0 0 counsel-async-filter-update-time))) + "Return `counsel-async-filter-update-time' as a time value.") + +(defun counsel--async-filter (process str) + "Receive from PROCESS the output STR. +Update the minibuffer with the amount of lines collected every +`counsel-async-filter-update-time' microseconds since the last update." + (with-current-buffer (process-buffer process) + (insert str)) + (when (time-less-p (counsel--async-filter-update-time) + (time-since counsel--async-time)) + (let (numlines) + (with-current-buffer (process-buffer process) + (setq numlines (count-lines (point-min) (point-max))) + (ivy--set-candidates + (let ((lines (counsel--split-string)) + (ignore-re (ivy-alist-setting counsel-async-ignore-re-alist))) + (if (stringp ignore-re) + (cl-delete-if (lambda (line) + (string-match-p ignore-re line)) + lines) + lines)))) + (let ((ivy--prompt (format "%d++ %s" numlines (ivy-state-prompt ivy-last)))) + (ivy--insert-minibuffer (ivy--format ivy--all-candidates))) + (setq counsel--async-time (current-time))))) + +(defun counsel-delete-process (&optional name) + "Delete current counsel process or that with NAME." + (let ((process (get-process (or name " *counsel*")))) + (when process + (delete-process process)))) + +;;; Completion at point + +(define-obsolete-function-alias 'counsel-el + #'complete-symbol "0.13.2 (2020-05-20)") +(define-obsolete-function-alias 'counsel-cl + #'complete-symbol "0.13.2 (2020-05-20)") +(define-obsolete-function-alias 'counsel-jedi + #'complete-symbol "0.13.2 (2020-05-20)") +(define-obsolete-function-alias 'counsel-clj + #'complete-symbol "0.13.2 (2020-05-20)") + +;;;; `counsel-company' + +(defvar company-candidates) +(declare-function company-abort "ext:company") +(declare-function company-complete "ext:company") +(declare-function company-mode "ext:company") +(declare-function company-call-backend "ext:company") +(declare-function company--clean-string "ext:company") +(declare-function company--continue "ext:company") + +;;;###autoload +(defun counsel-company () + "Complete using `company-candidates'." + (interactive) + (company-mode 1) + (unless company-candidates + (company-complete)) + (when company-candidates + (company--continue) + (ivy-read "Candidate: " company-candidates + :action 'company-finish + :caller 'counsel-company))) + +(ivy-configure 'counsel-company + :display-transformer-fn #'counsel--company-display-transformer + :unwind-fn (lambda() (unless ivy-exit (company-abort)))) + +(defun counsel--company-display-transformer (s) + (concat s (let ((annot (company-call-backend 'annotation s))) + (when annot + (company--clean-string annot))))) + +;;;; `counsel-irony' + +(declare-function irony-completion-candidates-async "ext:irony-completion") +(declare-function irony-completion-symbol-bounds "ext:irony-completion") +(declare-function irony-completion-annotation "ext:irony-completion") + +;;;###autoload +(defun counsel-irony () + "Inline C/C++ completion using Irony." + (interactive) + (irony-completion-candidates-async 'counsel-irony-callback)) + +(defun counsel-irony-callback (candidates) + "Callback function for Irony to search among CANDIDATES." + (interactive) + (let* ((symbol-bounds (irony-completion-symbol-bounds)) + (beg (car symbol-bounds)) + (end (cdr symbol-bounds)) + (prefix (buffer-substring-no-properties beg end))) + (setq ivy-completion-beg beg + ivy-completion-end end) + (ivy-read "code: " (mapcar #'counsel-irony-annotate candidates) + :predicate (lambda (candidate) + (string-prefix-p prefix (car candidate))) + :caller 'counsel-irony + :action #'ivy-completion-in-region-action))) + +(defun counsel-irony-annotate (x) + "Make Ivy candidate from Irony candidate X." + (cons (concat (car x) (irony-completion-annotation x)) + (car x))) + +(ivy-configure #'counsel-irony + :display-fn #'ivy-display-function-overlay) + +;;; Elisp symbols +;;;; `counsel-describe-variable' + +(defvar counsel-describe-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-.") #'counsel-find-symbol) + (define-key map (kbd "C-,") #'counsel--info-lookup-symbol) + map)) + +(ivy-set-actions + 'counsel-describe-variable + `(("I" ,#'counsel-info-lookup-symbol "info") + ("d" ,#'counsel--find-symbol "definition"))) + +(defvar counsel-describe-symbol-history () + "History list for variable and function names. +Used by commands `counsel-describe-symbol', +`counsel-describe-variable', and `counsel-describe-function'.") + +(defun counsel-find-symbol () + "Jump to the definition of the current symbol." + (interactive) + (ivy-exit-with-action #'counsel--find-symbol)) +(function-put #'counsel-find-symbol 'no-counsel-M-x t) + +(defun counsel--info-lookup-symbol () + "Lookup the current symbol in the info docs." + (interactive) + (ivy-exit-with-action #'counsel-info-lookup-symbol)) + +(defun counsel--push-xref-marker (&optional m) + "Compatibility shim for `xref-push-marker-stack'." + (static-if (require 'xref nil t) + ;; Added in Emacs 25.1. + (progn + (unless (fboundp 'xref-push-marker-stack) + (require 'xref)) + (xref-push-marker-stack m)) + (unless (boundp 'find-tag-marker-ring) + (require 'etags)) + (unless (fboundp 'ring-insert) + (require 'ring)) + (defvar find-tag-marker-ring) + (declare-function ring-insert "ring" (ring item)) + (ring-insert find-tag-marker-ring (or m (point-marker))))) + +(defun counsel--find-symbol (x) + "Find symbol definition that corresponds to string X." + (with-ivy-window + (counsel--push-xref-marker) + (let ((full-name (get-text-property 0 'full-name x))) + (if full-name + (find-library full-name) + (let ((sym (read x))) + (cond ((and (eq (ivy-state-caller ivy-last) + 'counsel-describe-variable) + (boundp sym)) + (find-variable sym)) + ((fboundp sym) + (find-function sym)) + ((boundp sym) + (find-variable sym)) + ((or (featurep sym) + (locate-library + (prin1-to-string sym))) + (find-library + (prin1-to-string sym))) + (t + (error "Couldn't find definition of %s" + sym)))))))) + +(defun counsel--variable-p (symbol) + "Return non-nil if SYMBOL is a bound or documented variable." + (or (and (boundp symbol) + (not (keywordp symbol))) + (get symbol 'variable-documentation))) + +(defcustom counsel-describe-variable-function #'describe-variable + "Function to call to describe a variable passed as parameter." + :type 'function) + +(defun counsel-describe-variable-transformer (var) + "Propertize VAR if it's a custom variable." + (if (custom-variable-p (intern var)) + (ivy-append-face var 'ivy-highlight-face) + var)) + +;;;###autoload +(defun counsel-describe-variable () + "Forward to `describe-variable'. + +Variables declared using `defcustom' are highlighted according to +`ivy-highlight-face'." + (interactive) + (let ((enable-recursive-minibuffers t)) + (ivy-read "Describe variable: " obarray + :predicate #'counsel--variable-p + :require-match t + :history 'counsel-describe-symbol-history + :keymap counsel-describe-map + :preselect (ivy-thing-at-point) + :action (lambda (x) + (funcall counsel-describe-variable-function (intern x))) + :caller 'counsel-describe-variable))) + +(ivy-configure 'counsel-describe-variable + :parent 'counsel-describe-symbol + :display-transformer-fn #'counsel-describe-variable-transformer) + +;;;; `counsel-describe-function' + +(ivy-set-actions + 'counsel-describe-function + `(("I" ,#'counsel-info-lookup-symbol "info") + ("d" ,#'counsel--find-symbol "definition"))) + +(defcustom counsel-describe-function-function #'describe-function + "Function to call to describe a function passed as parameter." + :type 'function) + +(defun counsel-describe-function-transformer (function-name) + "Propertize FUNCTION-NAME if it's an interactive function." + (if (commandp (intern function-name)) + (ivy-append-face function-name 'ivy-highlight-face) + function-name)) + +(defun ivy-function-called-at-point () + (let ((f (function-called-at-point))) + (and f (symbol-name f)))) + +(defcustom counsel-describe-function-preselect #'ivy-thing-at-point + "Determine what `counsel-describe-function' should preselect." + :type '(radio + (function-item ivy-thing-at-point) + (function-item ivy-function-called-at-point))) + +(defun counsel--describe-function (candidate) + "Pass string CANDIDATE to `counsel-describe-function-function'." + (funcall counsel-describe-function-function (intern candidate))) + +;;;###autoload +(defun counsel-describe-function () + "Forward to `describe-function'. + +Interactive functions (i.e., commands) are highlighted according +to `ivy-highlight-face'." + (interactive) + (let ((enable-recursive-minibuffers t)) + (ivy-read "Describe function: " obarray + :predicate (lambda (sym) + (or (fboundp sym) + (get sym 'function-documentation))) + :require-match t + :history 'counsel-describe-symbol-history + :keymap counsel-describe-map + :preselect (funcall counsel-describe-function-preselect) + :action #'counsel--describe-function + :caller 'counsel-describe-function))) + +(ivy-configure 'counsel-describe-function + :parent 'counsel-describe-symbol + :display-transformer-fn #'counsel-describe-function-transformer) + +;;;; `counsel-describe-symbol' + +(defcustom counsel-describe-symbol-function 'describe-symbol + "Function to call to describe a symbol passed as parameter." + :type 'function) + +;;;###autoload +(defun counsel-describe-symbol () + "Forward to `describe-symbol'." + (interactive) + (unless (functionp 'describe-symbol) + (user-error "This command requires Emacs 25.1 or later")) + (require 'help-mode) + (defvar describe-symbol-backends) + (let ((enable-recursive-minibuffers t)) + (ivy-read "Describe symbol: " obarray + :predicate (lambda (sym) + (cl-some (lambda (backend) + (funcall (cadr backend) sym)) + describe-symbol-backends)) + :require-match t + :history 'counsel-describe-symbol-history + :keymap counsel-describe-map + :preselect (ivy-thing-at-point) + :action (lambda (x) + (funcall counsel-describe-symbol-function (intern x))) + :caller 'counsel-describe-symbol))) + +(ivy-configure 'counsel-describe-symbol + :initial-input "^" + :sort-fn #'ivy-string<) + +(ivy-set-actions + 'counsel-describe-symbol + `(("I" ,#'counsel-info-lookup-symbol "info") + ("d" ,#'counsel--find-symbol "definition"))) + +;;;; `counsel-set-variable' + +(defvar counsel-set-variable-history nil + "Store history for `counsel-set-variable'.") + +(defun counsel-read-setq-expression (sym) + "Read and eval a setq expression for SYM." + (setq this-command 'eval-expression) + (let* ((sym-value (symbol-value sym)) + (init (format "(setq %s%S)" + (if (or (consp sym-value) + (and sym-value (symbolp sym-value))) + "'" + "") + sym-value))) + ;; Most of this duplicates `read--expression'. + (minibuffer-with-setup-hook + (lambda () + (set-syntax-table emacs-lisp-mode-syntax-table) + ;; Added in Emacs 25.1. + (when (fboundp 'elisp-completion-at-point) + (add-hook 'completion-at-point-functions + #'elisp-completion-at-point nil t)) + ;; Emacs 27+ already sets up ElDoc in this hook. Emacs 25 added + ;; `elisp-eldoc-documentation-function' and Emacs 28 obsoletes it. + (when (< emacs-major-version 27) + (when (fboundp 'elisp-eldoc-documentation-function) + (add-function :before-until (local 'eldoc-documentation-function) + #'elisp-eldoc-documentation-function)) + (eldoc-mode)) + (run-hooks 'eval-expression-minibuffer-setup-hook) + ;; The following diverges from `read--expression'. + (goto-char (minibuffer-prompt-end)) + (forward-char 6) + (insert (format "%S " sym))) + (read-from-minibuffer "Eval: " init read-expression-map t + 'read-expression-history)))) + +(defun counsel--setq-doconst (x) + "Return a cons of description and value for X. +X is an item of a radio- or choice-type defcustom." + (when (listp x) + (let ((v (car-safe (last x))) + (tag (and (eq (car x) 'const) + (plist-get (cdr x) :tag)))) + (when (and (or v tag) (not (eq v 'function))) + (cons + (concat + (when tag + (concat tag ": ")) + (if (stringp v) v (prin1-to-string v))) + (if (symbolp v) + (list 'quote v) + v)))))) + +(declare-function lv-message "ext:lv") +(declare-function lv-delete-window "ext:lv") +(declare-function custom-variable-documentation "cus-edit") + +(defface counsel-variable-documentation + '((t :inherit font-lock-comment-face)) + "Face for displaying Lisp documentation." + :group 'ivy-faces) + +;;;###autoload +(defun counsel-set-variable (sym) + "Set a variable SYM, with completion. + +When the selected variable is a `defcustom' with the type boolean +or radio, offer completion of all possible values. + +Otherwise, offer a variant of `eval-expression', with the initial +input corresponding to the chosen variable. + +With a prefix arg, restrict list to variables defined using +`defcustom'." + (interactive (list (intern + (ivy-read "Set variable: " obarray + :predicate (if current-prefix-arg + #'custom-variable-p + #'counsel--variable-p) + :history 'counsel-set-variable-history + :preselect (ivy-thing-at-point))))) + (let ((doc (and (require 'cus-edit) + (require 'lv nil t) + (not (string= "nil" (custom-variable-documentation sym))) + (propertize (custom-variable-documentation sym) + 'face 'counsel-variable-documentation))) + sym-type + cands) + (unwind-protect + (progn + (when doc + (lv-message (ivy--quote-format-string doc))) + (if (and (boundp sym) + (setq sym-type (get sym 'custom-type)) + (cond + ((and (consp sym-type) + (memq (car sym-type) '(choice radio))) + (setq cands (delq nil (mapcar #'counsel--setq-doconst + (cdr sym-type))))) + ((eq sym-type 'boolean) + (setq cands '(("nil" . nil) ("t" . t)))) + (t nil))) + (let* ((sym-val (symbol-value sym)) + (res (ivy-read (format "Set (%S <%s>): " sym sym-val) + cands + :preselect (prin1-to-string sym-val)))) + (when res + (setq res + (if (assoc res cands) + (cdr (assoc res cands)) + (read res))) + (kill-new (format "(setq %S %S)" sym res)) + (set sym (if (and (listp res) (eq (car res) 'quote)) + (cadr res) + res)))) + (unless (boundp sym) + (set sym nil)) + (let ((expr (counsel-read-setq-expression sym))) + (kill-new (format "%S" expr)) + (eval-expression expr)))) + (when doc + (lv-delete-window))))) + +;;;; `counsel-apropos' + +;;;###autoload +(defun counsel-apropos () + "Show all matching symbols. +See `apropos' for further information on what is considered +a symbol and how to search for them." + (interactive) + (ivy-read "Search for symbol (word list or regexp): " obarray + :predicate (lambda (sym) + (or (fboundp sym) + (boundp sym) + (facep sym) + (symbol-plist sym))) + :history 'counsel-apropos-history + :preselect (ivy-thing-at-point) + :action (lambda (pattern) + (when (string= pattern "") + (user-error "Please specify a pattern")) + ;; If the user selected a candidate form the list, we use + ;; a pattern which matches only the selected symbol. + (if (memq this-command '(ivy-immediate-done ivy-alt-done)) + ;; Regexp pattern are passed verbatim, other input is + ;; split into words. + (if (string= (regexp-quote pattern) pattern) + (apropos (split-string pattern "[ \t]+" t)) + (apropos pattern)) + (apropos (concat "\\`" pattern "\\'")))) + :caller 'counsel-apropos)) + +(ivy-configure 'counsel-apropos + :sort-fn #'ivy-string<) + +;;;; `counsel-info-lookup-symbol' + +(defvar info-lookup-mode) +(declare-function info-lookup-guess-default "info-look") +(declare-function info-lookup->completions "info-look") +(declare-function info-lookup->mode-value "info-look") +(declare-function info-lookup-select-mode "info-look") +(declare-function info-lookup-change-mode "info-look") +(declare-function info-lookup "info-look") + +;;;###autoload +(defun counsel-info-lookup-symbol (symbol &optional mode) + "Forward SYMBOL to `info-lookup-symbol' with ivy completion. +With prefix arg MODE a query for the symbol help mode is offered." + (interactive + (progn + (require 'info-look) + ;; Courtesy of `info-lookup-interactive-arguments' + (let* ((topic 'symbol) + (mode (cond (current-prefix-arg + (info-lookup-change-mode topic)) + ((info-lookup->mode-value + topic (info-lookup-select-mode)) + info-lookup-mode) + ((info-lookup-change-mode topic)))) + (enable-recursive-minibuffers t)) + (list (ivy-read "Describe symbol: " (info-lookup->completions topic mode) + :history 'info-lookup-history + :preselect (info-lookup-guess-default topic mode) + :caller 'counsel-info-lookup-symbol) + mode)))) + (info-lookup-symbol symbol mode)) + +(ivy-configure 'counsel-info-lookup-symbol + :sort-fn #'ivy-string<) + +;;;; `counsel-M-x' + +(defface counsel-key-binding + '((t :inherit font-lock-keyword-face)) + "Face used by `counsel-M-x' for key bindings." + :group 'ivy-faces) + +(defface counsel-active-mode + '((t :inherit font-lock-builtin-face)) + "Face used by `counsel-M-x' for activated modes." + :group 'ivy-faces) + +(defcustom counsel-alias-expand t + "When non-nil, show the expansion of aliases in `counsel-M-x'." + :type 'boolean + :group 'ivy) + +(defun counsel-M-x-transformer (cmd) + "Return CMD annotated with its active key binding, if any." + (let* ((sym (intern cmd)) + (alias (symbol-function sym)) + (key (where-is-internal sym nil t))) + (when (or (eq sym major-mode) + (and + (memq sym minor-mode-list) + (boundp sym) + (buffer-local-value sym (ivy-state-buffer ivy-last)))) + (setq cmd (propertize cmd 'face 'counsel-active-mode))) + (concat cmd + (when (and (symbolp alias) counsel-alias-expand) + (format " (%s)" alias)) + (when key + ;; Prefer `' over `C-x 6' where applicable + (let ((i (cl-search [?\C-x ?6] key))) + (when i + (let ((dup (vconcat (substring key 0 i) [f2] (substring key (+ i 2)))) + (map (current-global-map))) + (when (equal (lookup-key map key) + (lookup-key map dup)) + (setq key dup))))) + (setq key (key-description key)) + (put-text-property 0 (length key) 'face 'counsel-key-binding key) + (format " (%s)" key))))) + +(defvar amx-initialized) +(defvar amx-cache) +(declare-function amx-initialize "ext:amx") +(declare-function amx-detect-new-commands "ext:amx") +(declare-function amx-update "ext:amx") +(declare-function amx-rank "ext:amx") +(defvar smex-initialized-p) +(defvar smex-ido-cache) +(declare-function smex-initialize "ext:smex") +(declare-function smex-detect-new-commands "ext:smex") +(declare-function smex-update "ext:smex") +(declare-function smex-rank "ext:smex") + +(defun counsel--M-x-externs () + "Return `counsel-M-x' candidates from external packages. +The return value is a list of strings. The currently supported +packages are, in order of precedence, `amx' and `smex'." + (cond ((require 'amx nil t) + (unless amx-initialized + (amx-initialize)) + (when (amx-detect-new-commands) + (amx-update)) + (mapcar (lambda (entry) + (symbol-name (car entry))) + amx-cache)) + ((require 'smex nil t) + (unless smex-initialized-p + (smex-initialize)) + (when (smex-detect-new-commands) + (smex-update)) + smex-ido-cache))) + +(defun counsel--M-x-externs-predicate (cand) + "Return non-nil if `counsel-M-x' should complete CAND. +CAND is a string returned by `counsel--M-x-externs'." + (not (get (intern cand) 'no-counsel-M-x))) + +(defun counsel--M-x-make-predicate () + "Return a predicate for `counsel-M-x' in the current buffer." + (defvar read-extended-command-predicate) + (let ((buf (current-buffer))) + (lambda (sym) + (and (commandp sym) + (not (get sym 'byte-obsolete-info)) + (not (get sym 'no-counsel-M-x)) + (cond ((not (bound-and-true-p read-extended-command-predicate))) + ((functionp read-extended-command-predicate) + (condition-case-unless-debug err + (funcall read-extended-command-predicate sym buf) + (error (message "read-extended-command-predicate: %s: %s" + sym (error-message-string err)))))))))) + +(defun counsel--M-x-prompt () + "String for `M-x' plus the string representation of `current-prefix-arg'." + (concat (cond ((null current-prefix-arg) + nil) + ((eq current-prefix-arg '-) + "- ") + ((integerp current-prefix-arg) + (format "%d " current-prefix-arg)) + ((= (car current-prefix-arg) 4) + "C-u ") + (t + (format "%d " (car current-prefix-arg)))) + "M-x ")) + +(defvar counsel-M-x-history nil + "History for `counsel-M-x'.") + +(defun counsel-M-x-action (cmd) + "Execute CMD." + (setq cmd (intern + (subst-char-in-string ?\s ?- (string-remove-prefix "^" cmd)))) + (cond ((bound-and-true-p amx-initialized) + (amx-rank cmd)) + ((bound-and-true-p smex-initialized-p) + (smex-rank cmd))) + (setq prefix-arg current-prefix-arg) + (setq this-command cmd) + (setq real-this-command cmd) + (command-execute cmd 'record)) + +;;;###autoload +(defun counsel-M-x (&optional initial-input) + "Ivy version of `execute-extended-command'. +Optional INITIAL-INPUT is the initial input in the minibuffer. +This function integrates with either the `amx' or `smex' package +when available, in that order of precedence." + (interactive) + ;; When `counsel-M-x' returns, `last-command' would be set to + ;; `counsel-M-x' because :action hasn't been invoked yet. + ;; Instead, preserve the old value of `this-command'. + (setq this-command last-command) + (setq real-this-command real-last-command) + (let ((externs (counsel--M-x-externs))) + (ivy-read (counsel--M-x-prompt) (or externs obarray) + :predicate (if externs + #'counsel--M-x-externs-predicate + (counsel--M-x-make-predicate)) + :require-match t + :history 'counsel-M-x-history + :action #'counsel-M-x-action + :keymap counsel-describe-map + :initial-input initial-input + :caller 'counsel-M-x))) + +(ivy-configure 'counsel-M-x + :initial-input "^" + :display-transformer-fn #'counsel-M-x-transformer) + +(ivy-set-actions + 'counsel-M-x + `(("d" ,#'counsel--find-symbol "definition") + ("h" ,#'counsel--describe-function "help"))) + +;;;; `counsel-command-history' + +(defun counsel-command-history-action-eval (cmd) + "Eval the command CMD." + (eval (read cmd) t)) + +(defun counsel-command-history-action-edit-and-eval (cmd) + "Edit and eval the command CMD." + (edit-and-eval-command "Eval: " (read cmd))) + +(ivy-set-actions + 'counsel-command-history + '(("r" counsel-command-history-action-eval "eval command") + ("e" counsel-command-history-action-edit-and-eval "edit and eval command"))) + +;;;###autoload +(defun counsel-command-history () + "Show the history of commands." + (interactive) + (ivy-read "Command: " (mapcar #'prin1-to-string command-history) + :require-match t + :action #'counsel-command-history-action-eval + :caller 'counsel-command-history)) + +;;;; `counsel-load-library' + +(defun counsel-library-candidates () + "Return a list of completion candidates for `counsel-load-library'." + (let ((suffix (concat (regexp-opt '(".el" ".el.gz") t) "\\'")) + (cands (make-hash-table :test #'equal)) + short-name + old-val + dir-parent + res) + (dolist (dir load-path) + (setq dir (or dir default-directory)) ;; interpret nil in load-path as default-directory + (when (file-directory-p dir) + (dolist (file (file-name-all-completions "" dir)) + (when (string-match suffix file) + (unless (string-match "pkg.elc?$" file) + (setq short-name (substring file 0 (match-beginning 0))) + (if (setq old-val (gethash short-name cands)) + (progn + ;; assume going up directory once will resolve name clash + (setq dir-parent (counsel-directory-name (cdr old-val))) + (puthash short-name + (cons + (counsel-string-compose dir-parent (car old-val)) + (cdr old-val)) + cands) + (setq dir-parent (counsel-directory-name dir)) + (puthash (concat dir-parent short-name) + (cons + (propertize + (counsel-string-compose + dir-parent short-name) + 'full-name (expand-file-name file dir)) + dir) + cands)) + (puthash short-name + (cons (propertize + short-name + 'full-name (expand-file-name file dir)) + dir) + cands))))))) + (maphash (lambda (_k v) (push (car v) res)) cands) + (nreverse res))) + +;;;###autoload +(defun counsel-load-library () + "Load a selected the Emacs Lisp library. +The libraries are offered from `load-path'." + (interactive) + (let ((cands (counsel-library-candidates))) + (ivy-read "Load library: " cands + :action (lambda (x) + (load-library + (get-text-property 0 'full-name x))) + :keymap counsel-describe-map))) + +(ivy-set-actions + 'counsel-load-library + `(("d" ,#'counsel--find-symbol "definition"))) + +;;;; `counsel-find-library' + +(declare-function find-library-name "find-func") +(defun counsel-find-library-other-window (library) + (let ((buf (find-file-noselect (find-library-name library)))) + (pop-to-buffer buf 'other-window))) + +(defun counsel-find-library-other-frame (library) + (let ((buf (find-file-noselect (find-library-name library)))) + (condition-case nil + (switch-to-buffer-other-frame buf) + (error (pop-to-buffer buf))))) + +(ivy-set-actions + 'counsel-find-library + '(("j" counsel-find-library-other-window "other window") + ("f" counsel-find-library-other-frame "other frame"))) + +;;;###autoload +(defun counsel-find-library () + "Visit a selected the Emacs Lisp library. +The libraries are offered from `load-path'." + (interactive) + (let ((cands (counsel-library-candidates))) + (ivy-read "Find library: " cands + :action #'counsel--find-symbol + :keymap counsel-describe-map + :caller 'counsel-find-library))) + +;;;; `counsel-load-theme' + +(declare-function powerline-reset "ext:powerline") + +(defun counsel-load-theme-action (x) + "Disable current themes and load theme X." + (condition-case nil + (progn + (mapc #'disable-theme custom-enabled-themes) + (load-theme (intern x) t) + (when (fboundp 'powerline-reset) + (powerline-reset))) + (error "Problem loading theme %s" x))) + +;;;###autoload +(defun counsel-load-theme () + "Forward to `load-theme'. +Usable with `ivy-resume', `ivy-next-line-and-call' and +`ivy-previous-line-and-call'." + (interactive) + (ivy-read "Load custom theme: " + (mapcar #'symbol-name + (custom-available-themes)) + :action #'counsel-load-theme-action + :caller 'counsel-load-theme)) + +;;;; `counsel-descbinds' + +(ivy-set-actions + 'counsel-descbinds + '(("d" counsel-descbinds-action-find "definition") + ("I" counsel-descbinds-action-info "info") + ("x" counsel-descbinds-action-exec "execute"))) + +(defvar counsel-descbinds-history nil + "History for `counsel-descbinds'.") + +(defun counsel--descbinds-cands (&optional prefix buffer) + "Get key bindings starting with PREFIX in BUFFER. +See `describe-buffer-bindings' for further information." + (let ((buffer (or buffer (current-buffer))) + (re-exclude (regexp-opt + '("" "" "" + "" "" "" + "" "" + "" ""))) + res) + (with-temp-buffer + (let ((indent-tabs-mode t)) + (describe-buffer-bindings buffer prefix)) + (goto-char (point-min)) + ;; Skip the "Key translations" section + (skip-chars-forward "^\C-l") + (forward-char 2) + (while (not (eobp)) + (when (looking-at "^\\([^\t\n]+\\)[\t ]*\\(.*\\)$") + (let ((key (match-string 1)) + (fun (match-string 2)) + cmd) + (unless (or (member fun '("??" "self-insert-command")) + (string-match-p re-exclude key) + (not (or (commandp (setq cmd (intern-soft fun))) + (equal fun "Prefix Command")))) + (push + (cons (format + "%-15s %s" + (propertize key 'face 'counsel-key-binding) + fun) + (cons key cmd)) + res)))) + (forward-line))) + (nreverse res))) + +(defcustom counsel-descbinds-function #'describe-function + "Function to call to describe a function passed as parameter." + :type 'function) + +(defun counsel-descbinds-action-describe (x) + "Describe function of candidate X. +See `describe-function' for further information." + (let ((cmd (cddr x))) + (funcall counsel-descbinds-function cmd))) + +(defun counsel-descbinds-action-exec (x) + "Run candidate X. +See `execute-extended-command' for further information." + (let ((cmd (cddr x))) + (command-execute cmd 'record))) + +(defun counsel-descbinds-action-find (x) + "Find symbol definition of candidate X. +See `counsel--find-symbol' for further information." + (let ((cmd (cddr x))) + (counsel--find-symbol (symbol-name cmd)))) + +(defun counsel-descbinds-action-info (x) + "Display symbol definition of candidate X, as found in the relevant manual. +See `info-lookup-symbol' for further information." + (let ((cmd (cddr x))) + (counsel-info-lookup-symbol (symbol-name cmd)))) + +;;;###autoload +(defun counsel-descbinds (&optional prefix buffer) + "Show a list of all defined keys and their definitions. +If non-nil, show only bindings that start with PREFIX. +BUFFER defaults to the current one." + (interactive) + (ivy-read "Bindings: " (counsel--descbinds-cands prefix buffer) + :action #'counsel-descbinds-action-describe + :history 'counsel-descbinds-history + :caller 'counsel-descbinds)) + +;;;; `counsel-describe-face' + +(defcustom counsel-describe-face-function #'describe-face + "Function to call to describe a face or face name argument." + :type 'function) + +(defun counsel--face-at-point () + "Return name of face around point. +Try detecting a face name in the text around point before falling +back to the face of the character after point, and finally the +`default' face." + (symbol-name (or (face-at-point t) 'default))) + +;;;###autoload +(defun counsel-describe-face () + "Completion for `describe-face'." + (interactive) + (ivy-read "Face: " (face-list) + :require-match t + :history 'face-name-history + :preselect (counsel--face-at-point) + :action counsel-describe-face-function + :caller 'counsel-describe-face)) + +(ivy-configure 'counsel-describe-face + :sort-fn #'ivy-string<) + +(defun counsel-customize-face (name) + "Customize face with NAME." + (customize-face (intern name))) + +(defun counsel-customize-face-other-window (name) + "Customize face with NAME in another window." + (customize-face-other-window (intern name))) + +(declare-function hi-lock-set-pattern "hi-lock") +(defun counsel-highlight-with-face (face) + "Highlight thing-at-point with FACE." + (hi-lock-mode 1) + (let ((thing (ivy-thing-at-point))) + (when (use-region-p) + (deactivate-mark)) + (hi-lock-set-pattern (regexp-quote thing) (intern face)))) + +(ivy-set-actions + 'counsel-describe-face + '(("c" counsel-customize-face "customize") + ("C" counsel-customize-face-other-window "customize other window"))) + +;;;; `counsel-faces' + +(defvar counsel--faces-format "%-40s %s") + +(defun counsel--faces-format-function (names) + "Format NAMES according to `counsel--faces-format'." + (let ((formatter + (lambda (name) + (format counsel--faces-format name + (propertize list-faces-sample-text + 'face (intern name)))))) + (ivy--format-function-generic + (lambda (name) + (funcall formatter (ivy--add-face name 'ivy-current-match))) + formatter names "\n"))) + +;;;###autoload +(defun counsel-faces () + "Complete faces with preview. +Actions are provided by default for describing or customizing the +selected face." + (interactive) + (let* ((names (mapcar #'symbol-name (face-list))) + (counsel--faces-format + (format "%%-%ds %%s" + (apply #'max 0 (mapcar #'string-width names))))) + (ivy-read "Face: " names + :require-match t + :history 'face-name-history + :preselect (counsel--face-at-point) + :action counsel-describe-face-function + :caller 'counsel-faces))) + +(ivy-configure 'counsel-faces + :parent 'counsel-describe-face + :format-fn #'counsel--faces-format-function) + +(ivy-set-actions + 'counsel-faces + '(("c" counsel-customize-face "customize") + ("C" counsel-customize-face-other-window "customize other window") + ("h" counsel-highlight-with-face "highlight"))) + +;;;; Modes + +(defvar counsel-minor-history nil + "History for `counsel-minor'.") + +(defun counsel--minor-candidates () + "Return completion alist for `counsel-minor'. + +The alist element is cons of minor mode string with its lighter +and minor mode symbol." + (cl-mapcan + (let ((suffix (propertize " \"%s\"" 'face 'font-lock-string-face))) + (lambda (mode) + (when (and (boundp mode) (commandp mode)) + (let ((lighter (cdr (assq mode minor-mode-alist)))) + (list (cons (concat + (if (symbol-value mode) "-" "+") + (symbol-name mode) + (and lighter + (format suffix + (format-mode-line (cons t lighter))))) + mode)))))) + minor-mode-list)) + +;;;###autoload +(defun counsel-minor () + "Enable or disable minor mode. + +Disabled minor modes are prefixed with \"+\", and +selecting one of these will enable it. +Enabled minor modes are prefixed with \"-\", and +selecting one of these will enable it. + +Additional actions:\\ + + \\[ivy-dispatching-done] d: Go to minor mode definition + \\[ivy-dispatching-done] h: Describe minor mode" + + (interactive) + (ivy-read "Minor modes (enable +mode or disable -mode): " + (counsel--minor-candidates) + :require-match t + :history 'counsel-minor-history + :action (lambda (x) + (call-interactively (cdr x))))) + +(ivy-configure 'counsel-minor + :initial-input "^+" + :sort-fn #'ivy-string<) + +(ivy-set-actions + 'counsel-minor + `(("d" ,(lambda (x) (find-function (cdr x))) "definition") + ("h" ,(lambda (x) (describe-function (cdr x))) "help"))) + +;;;###autoload +(defun counsel-major () + (interactive) + (ivy-read "Major modes: " obarray + :predicate (lambda (f) + (and (commandp f) + (string-suffix-p "-mode" (symbol-name f)) + (or (and (autoloadp (symbol-function f)) + (let ((doc-split (help-split-fundoc (documentation f) f))) + ;; major mode starters have no arguments + (and doc-split (null (cdr (read (car doc-split))))))) + (null (help-function-arglist f))))) + :action #'counsel-M-x-action + :caller 'counsel-major)) + +;;; Git +;;;; `counsel-git' + +(defvar counsel-git-cmd "git ls-files -z --full-name --" + "Command for `counsel-git'.") + +(ivy-set-actions + 'counsel-git + '(("j" find-file-other-window "other window") + ("x" counsel-find-file-extern "open externally"))) + +(defun counsel--dominating-file (file &optional dir) + "Look up directory hierarchy for FILE, starting in DIR. +Like `locate-dominating-file', but DIR defaults to +`default-directory' and the return value is expanded." + (and (setq dir (locate-dominating-file (or dir default-directory) file)) + (expand-file-name dir))) + +(defun counsel-locate-git-root () + "Return the root of the Git repository containing the current buffer." + (or (counsel--git-root) + (error "Not in a Git repository"))) + +(defun counsel-git-cands (dir) + (let ((default-directory dir)) + (split-string + (shell-command-to-string counsel-git-cmd) + "\0" + t))) + +(defvar counsel-git-history nil + "History for `counsel-git'.") + +;;;###autoload +(defun counsel-git (&optional initial-input) + "Find file in the current Git repository. +INITIAL-INPUT can be given as the initial minibuffer input." + (interactive) + (counsel-require-program counsel-git-cmd) + (let ((default-directory (counsel-locate-git-root))) + (ivy-read "Find file: " (counsel-git-cands default-directory) + :initial-input initial-input + :action #'counsel-git-action + :history 'counsel-git-history + :caller 'counsel-git))) + +(ivy-configure 'counsel-git + :occur #'counsel-git-occur) + +(defun counsel-git-action (x) + "Find file X in current Git repository." + (with-ivy-window + (let ((default-directory (ivy-state-directory ivy-last))) + (find-file x)))) + +(defun counsel-git-occur (&optional _cands) + "Occur function for `counsel-git' using `counsel-cmd-to-dired'." + (cd (ivy-state-directory ivy-last)) + (counsel-cmd-to-dired + (counsel--expand-ls + (format "%s | %s | xargs ls" + (replace-regexp-in-string + "\\(-0\\)\\|\\(-z\\)" "" counsel-git-cmd t t) + (counsel--file-name-filter))))) + +(defvar counsel-dired-listing-switches "-alh" + "Switches passed to `ls' for `counsel-cmd-to-dired'.") + +(defun counsel-cmd-to-dired (full-cmd &optional filter) + "Adapted from `find-dired'." + (let ((inhibit-read-only t)) + (erase-buffer) + (dired-mode default-directory counsel-dired-listing-switches) + (defvar dired-sort-inhibit) + (defvar dired-subdir-alist) + (declare-function dired-insert-set-properties "dired") + (declare-function dired-move-to-filename "dired") + (insert " " default-directory ":\n") + (let ((point (point))) + (insert " " full-cmd "\n") + (dired-insert-set-properties point (point))) + (setq-local dired-sort-inhibit t) + (setq-local revert-buffer-function + (lambda (_1 _2) (counsel-cmd-to-dired full-cmd))) + (setq-local dired-subdir-alist + (list (cons default-directory (point-min-marker)))) + (let ((proc (start-process-shell-command + "counsel-cmd" (current-buffer) full-cmd))) + (set-process-filter proc filter) + (set-process-sentinel + proc + (lambda (process _msg) + (when (and (eq (process-status process) 'exit) + (zerop (process-exit-status process))) + (goto-char (point-min)) + (forward-line 2) + (dired-move-to-filename))))))) + +;;;; `counsel-git-grep' + +(defvar counsel-git-grep-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-l") #'ivy-call-and-recenter) + (define-key map (kbd "M-q") #'counsel-git-grep-query-replace) + (define-key map (kbd "C-c C-m") #'counsel-git-grep-switch-cmd) + (define-key map (kbd "C-x C-d") #'counsel-cd) + map)) + +(defvar counsel-git-grep-cmd-default "git --no-pager grep -n --no-color -I -e \"%s\"" + "Initial command for `counsel-git-grep'.") + +(defvar counsel-git-grep-cmd nil + "Store the command for `counsel-git-grep'.") + +(defvar counsel-git-grep-history nil + "History for `counsel-git-grep'.") + +(defvar counsel-git-grep-cmd-history + (list counsel-git-grep-cmd-default) + "History for `counsel-git-grep' shell commands.") + +(defcustom counsel-grep-post-action-hook nil + "Hook that runs after the point moves to the next candidate. +A typical example of what to add to this hook is the function +`recenter'." + :type 'hook + :options '(recenter)) + +(defcustom counsel-git-grep-cmd-function #'counsel-git-grep-cmd-function-default + "How a git-grep shell call is built from the input. +This function should set `ivy--old-re'." + :type '(radio + (function-item counsel-git-grep-cmd-function-default) + (function-item counsel-git-grep-cmd-function-ignore-order) + (function :tag "Other"))) + +(defun counsel-git-grep-cmd-function-default (str) + (format counsel-git-grep-cmd + (setq ivy--old-re + (if (eq ivy--regex-function #'ivy--regex-fuzzy) + (ivy--string-replace "\n" "" (ivy--regex-fuzzy str)) + (ivy--regex str t))))) + +(defun counsel-git-grep-cmd-function-ignore-order (str) + (setq ivy--old-re (ivy--regex str t)) + (let ((parts (split-string str " " t))) + (concat + "git --no-pager grep --full-name -n --no-color -i -e " + (mapconcat #'shell-quote-argument parts " --and -e ")))) + +(defun counsel-git-grep-function (string) + "Grep in the current Git repository for STRING." + (or + (ivy-more-chars) + (ignore + (counsel--async-command + (concat + (funcall counsel-git-grep-cmd-function string) + (and (ivy--case-fold-p string) " -i")))))) + +(defun counsel-git-grep-action (x) + "Go to occurrence X in current Git repository." + (counsel--git-grep-visit x)) + +(defun counsel-git-grep-action-other-window (x) + "Go to occurrence X in current Git repository in another window." + (counsel--git-grep-visit x t)) + +(defun counsel--git-grep-file-and-line (x) + "Extract file name and line number from `counsel-git-grep' line X. +Return a pair (FILE . LINE) on success; nil otherwise." + (and (string-match "\\`\\(.*?\\):\\([0-9]+\\):\\(.*\\)\\'" x) + (cons (match-string-no-properties 1 x) + (string-to-number (match-string-no-properties 2 x))))) + +(defun counsel--git-grep-visit (cand &optional other-window) + "Visit `counsel-git-grep' CAND, optionally in OTHER-WINDOW." + (let ((file-and-line (counsel--git-grep-file-and-line cand))) + (when file-and-line + (funcall (if other-window #'find-file-other-window #'find-file) + (expand-file-name (car file-and-line) + (ivy-state-directory ivy-last))) + (goto-char (point-min)) + (forward-line (1- (cdr file-and-line))) + (when (re-search-forward (ivy--regex ivy-text t) (line-end-position) t) + (when swiper-goto-start-of-match + (goto-char (match-beginning 0)))) + (swiper--ensure-visible) + (run-hooks 'counsel-grep-post-action-hook) + (unless (eq ivy-exit 'done) + (swiper--cleanup) + (swiper--add-overlays (ivy--regex ivy-text)))))) + +(ivy-set-actions + 'counsel-git-grep + '(("j" counsel-git-grep-action-other-window "other window"))) + +(defun counsel-git-grep-transformer (str) + "Highlight file and line number in STR." + (when (string-match "\\`\\([^:]+\\):\\([^:]+\\):" str) + (add-face-text-property (match-beginning 1) (match-end 1) + 'ivy-grep-info nil str) + (add-face-text-property (match-beginning 2) (match-end 2) + 'ivy-grep-line-number nil str)) + str) + +(defvar counsel-git-grep-projects-alist nil + "An alist of project directory to \"git-grep\" command. +Allows to automatically use a custom \"git-grep\" command for all +files in a project.") + +(defun counsel--git-grep-cmd-and-proj (cmd) + (let ((dd (expand-file-name default-directory)) + proj) + (cond + ((stringp cmd)) + (current-prefix-arg + (if (setq proj + (cl-find-if + (lambda (x) + (string-match-p (car x) dd)) + counsel-git-grep-projects-alist)) + (setq cmd (cdr proj)) + (setq cmd + (ivy-read "cmd: " counsel-git-grep-cmd-history + :history 'counsel-git-grep-cmd-history + :re-builder #'ivy--regex)) + (setq counsel-git-grep-cmd-history + (delete-dups counsel-git-grep-cmd-history)))) + (t + (setq cmd counsel-git-grep-cmd-default))) + (cons proj cmd))) + +(defun counsel--call (command &optional result-fn) + "Synchronously call COMMAND and return its output as a string. +COMMAND comprises the program name followed by its arguments, as +in `make-process'. Signal `file-error' and emit a warning if +COMMAND fails. Obey file handlers based on `default-directory'. +On success, RESULT-FN is called in output buffer with no arguments." + (let ((stderr (make-temp-file "counsel-call-stderr-")) + status) + (unwind-protect + (with-temp-buffer + (setq status (apply #'process-file (car command) nil + (list t stderr) nil (cdr command))) + (if (eq status 0) + (if result-fn + (funcall result-fn) + ;; Return all output except trailing newline. + (buffer-substring (point-min) + (- (point) + (if (eq (bobp) (bolp)) + 0 + 1)))) + ;; Convert process status into error list. + (setq status (list 'file-error + (mapconcat #'identity `(,@command "failed") " ") + status)) + ;; Print stderr contents, if any, to *Warnings* buffer. + (let ((msg (condition-case err + (unless (zerop (cadr (insert-file-contents + stderr nil nil nil t))) + (buffer-string)) + (error (error-message-string err))))) + (lwarn 'ivy :warning "%s" (apply #'concat + (error-message-string status) + (and msg (list "\n" msg))))) + ;; Signal `file-error' with process status. + (signal (car status) (cdr status)))) + (delete-file stderr)))) + +(defun counsel--command (&rest command) + "Forward COMMAND to `counsel--call'." + (counsel--call command)) + +(defun counsel--grep-unwind () + (counsel-delete-process) + (swiper--cleanup)) + +;;;###autoload +(defun counsel-git-grep (&optional initial-input initial-directory cmd) + "Grep for a string in the current Git repository. +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search. +When CMD is a string, use it as a \"git grep\" command. +When CMD is non-nil, prompt for a specific \"git grep\" command." + (interactive) + (let ((proj-and-cmd (counsel--git-grep-cmd-and-proj cmd)) + proj) + (setq proj (car proj-and-cmd)) + (setq counsel-git-grep-cmd (cdr proj-and-cmd)) + (counsel-require-program counsel-git-grep-cmd) + (let ((collection-function + (if proj + #'counsel-git-grep-proj-function + #'counsel-git-grep-function)) + (default-directory (or initial-directory + (if proj + (car proj) + (counsel-locate-git-root))))) + (ivy-read "git grep: " collection-function + :initial-input initial-input + :dynamic-collection t + :keymap counsel-git-grep-map + :action #'counsel-git-grep-action + :history 'counsel-git-grep-history + :require-match t + :caller 'counsel-git-grep)))) + +(defun counsel--git-grep-index (_re-str cands) + (let (name ln) + (cond + (ivy--old-cands + (ivy-recompute-index-swiper-async nil cands)) + ((unless (with-ivy-window + (when buffer-file-name + (setq ln (line-number-at-pos)) + (setq name (file-name-nondirectory buffer-file-name)))) + 0)) + ;; Closest to current line going forwards. + ((let ((beg (1+ (length name)))) + (cl-position-if (lambda (x) + (and (string-prefix-p name x) + (>= (string-to-number (substring x beg)) ln))) + cands))) + ;; Closest to current line going backwards. + ((cl-position-if (lambda (x) + (string-prefix-p name x)) + cands + :from-end t)) + (t 0)))) + +(ivy-configure 'counsel-git-grep + :occur #'counsel-git-grep-occur + :unwind-fn #'counsel--grep-unwind + :index-fn #'counsel--git-grep-index + :display-transformer-fn #'counsel-git-grep-transformer + :grep-p t + :exit-codes '(1 "No matches found")) + +(defun counsel-git-grep-proj-function (str) + "Grep for STR in the current Git repository." + (or + (ivy-more-chars) + (let ((regex (setq ivy--old-re + (ivy--regex str t)))) + (counsel--async-command + (concat + (format counsel-git-grep-cmd regex) + (if (ivy--case-fold-p str) " -i" ""))) + nil))) + +(defun counsel-git-grep-switch-cmd () + "Set `counsel-git-grep-cmd' to a different value." + (interactive) + (setq counsel-git-grep-cmd + (ivy-read "cmd: " counsel-git-grep-cmd-history + :history 'counsel-git-grep-cmd-history)) + (setq counsel-git-grep-cmd-history + (delete-dups counsel-git-grep-cmd-history)) + (unless (ivy-state-dynamic-collection ivy-last) + (setq ivy--all-candidates + (all-completions "" #'counsel-git-grep-function)))) + +(defun counsel--normalize-grep-match (str) + ;; Prepend ./ if necessary: + (unless (ivy--starts-with-dotslash str) + (setq str (concat "./" str))) + ;; Remove column info if any: + (save-match-data + (when (string-match + "[^\n:]+?[^\n/:]:[\t ]*[1-9][0-9]*[\t ]*:\\([1-9][0-9]*:\\)" + str) + (setq str (replace-match "" t t str 1)))) + str) + +(defun counsel--git-grep-occur-cmd (input) + (let* ((regex ivy--old-re) + (positive-pattern ;; git-grep can't handle .*? + (ivy--string-replace ".*?" ".*" (ivy-re-to-str regex))) + (negative-patterns + (if (stringp regex) "" + (mapconcat (lambda (x) + (and (null (cdr x)) + (format "| grep -v %s" (car x)))) + regex + " ")))) + (concat + (format counsel-git-grep-cmd positive-pattern) + negative-patterns + (if (ivy--case-fold-p input) " -i" "")))) + +(defun counsel-git-grep-occur (&optional _cands) + "Generate a custom occur buffer for `counsel-git-grep'." + (counsel-grep-like-occur #'counsel--git-grep-occur-cmd)) + +(defun counsel-git-grep-query-replace () + "Start `query-replace' with string to replace from last search string." + (interactive) + (unless (window-minibuffer-p) + (user-error + "Should only be called in the minibuffer through `counsel-git-grep-map'")) + (let* ((enable-recursive-minibuffers t) + (from (ivy--regex ivy-text)) + (to (query-replace-read-to from "Query replace" t))) + (ivy-exit-with-action + (lambda (_) + (let (done-buffers) + (dolist (cand ivy--old-cands) + (when (string-match "\\`\\(.*?\\):\\([0-9]+\\):\\(.*\\)\\'" cand) + (with-ivy-window + (let ((file-name (match-string-no-properties 1 cand))) + (setq file-name (expand-file-name + file-name + (ivy-state-directory ivy-last))) + (unless (member file-name done-buffers) + (push file-name done-buffers) + (find-file file-name) + (goto-char (point-min))) + (perform-replace from to t t nil)))))))))) + +;;;; `counsel-git-stash' + +(defun counsel-git-stash-kill-action (x) + "Add git stash command to kill ring. +The git command applies the stash entry where candidate X was found in." + (when (string-match "\\([^:]+\\):" x) + (kill-new (message (format "git stash apply %s" (match-string 1 x)))))) + +;;;###autoload +(defun counsel-git-stash () + "Search through all available git stashes." + (interactive) + (let* ((default-directory (counsel-locate-git-root)) + (cands (split-string (shell-command-to-string + "IFS=$'\n' +for i in `git stash list --format=\"%gd\"`; do + git stash show -p $i | grep -H --label=\"$i\" \"$1\" +done") "\n" t))) + (ivy-read "git stash: " cands + :action #'counsel-git-stash-kill-action + :caller 'counsel-git-stash))) + +;;;; `counsel-git-log' + +(defvar counsel-git-log-cmd "GIT_PAGER=cat git log --no-color --grep '%s'" + "Command used for \"git log\".") + +(defun counsel-git-log-function (_) + "Search for `ivy-regex' in git log." + (or + (ivy-more-chars) + (progn + ;; `counsel--yank-pop-format-function' uses this + (setq ivy--old-re ivy-regex) + (counsel--async-command + ;; "git log --grep" likes to have groups quoted e.g. \(foo\). + ;; But it doesn't like the non-greedy ".*?". + (format counsel-git-log-cmd + (ivy--string-replace ".*?" ".*" (ivy-re-to-str ivy--old-re)))) + nil))) + +(defun counsel-git-log-action (x) + "Add candidate X to kill ring." + (message "%S" (kill-new x))) + +(declare-function magit-show-commit "ext:magit-diff") + +(defun counsel-git-log-show-commit-action (log-entry) + "Visit the commit corresponding to LOG-ENTRY." + (require 'magit-diff) + (let ((commit (substring-no-properties log-entry 0 (string-match-p "\\W" log-entry)))) + (magit-show-commit commit))) + +(ivy-set-actions + 'counsel-git-log + '(("v" counsel-git-log-show-commit-action "visit commit"))) + +;;;; `counsel-git-change-worktree' + +(defun counsel-git-change-worktree-action (git-root-dir tree) + "Find the corresponding file in the worktree located at tree. +The current buffer is assumed to be in a subdirectory of GIT-ROOT-DIR. +TREE is the selected candidate." + (let* ((new-root-dir (counsel-git-worktree-parse-root tree)) + (tree-filename (file-relative-name buffer-file-name git-root-dir)) + (file-name (expand-file-name tree-filename new-root-dir))) + (find-file file-name))) + +(defun counsel-git-worktree-list () + "List worktrees in the Git repository containing the current buffer." + (let ((default-directory (counsel-locate-git-root))) + (split-string (shell-command-to-string "git worktree list") "\n" t))) + +(defun counsel-git-worktree-parse-root (tree) + "Return worktree from candidate TREE." + (substring tree 0 (ivy--string-search " " tree))) + +(defun counsel-git-close-worktree-files-action (root-dir) + "Close all buffers from the worktree located at ROOT-DIR." + (setq root-dir (counsel-git-worktree-parse-root root-dir)) + (save-excursion + (dolist (buf (buffer-list)) + (set-buffer buf) + (and buffer-file-name + (string= "." (file-relative-name root-dir (counsel-locate-git-root))) + (kill-buffer buf))))) + +(ivy-set-actions + 'counsel-git-change-worktree + '(("k" counsel-git-close-worktree-files-action "kill all"))) + +;;;###autoload +(defun counsel-git-change-worktree () + "Find the file corresponding to the current buffer on a different worktree." + (interactive) + (let ((default-directory (counsel-locate-git-root))) + (ivy-read "Select worktree: " + (or (cl-delete default-directory (counsel-git-worktree-list) + :key #'counsel-git-worktree-parse-root :test #'string=) + (error "No other worktrees")) + :action (lambda (tree) + (counsel-git-change-worktree-action + (ivy-state-directory ivy-last) tree)) + :require-match t + :caller 'counsel-git-change-worktree))) + +;;;; `counsel-git-checkout' + +(defun counsel-git-checkout-action (branch) + "Switch branch by invoking git-checkout(1). +The command is passed a single argument comprising all characters +in BRANCH up to, but not including, the first space +character (#x20), or the string's end if it lacks a space." + (shell-command + (format "git checkout %s" + (shell-quote-argument + (substring branch 0 (ivy--string-search " " branch)))))) + +(defun counsel-git-branch-list () + "Return list of branches in the current Git repository. +Value comprises all local and remote branches bar the one +currently checked out." + (cl-mapcan (lambda (line) + (and (string-match "\\`[[:blank:]]+" line) + (list (substring line (match-end 0))))) + (let ((default-directory (counsel-locate-git-root))) + (split-string (shell-command-to-string + "git branch -vv --all --no-color") + "\n" t)))) + +;;;###autoload +(defun counsel-git-checkout () + "Call the \"git checkout\" command." + (interactive) + (ivy-read "Checkout branch: " (counsel-git-branch-list) + :action #'counsel-git-checkout-action + :caller 'counsel-git-checkout)) + +(defvar counsel-yank-pop-truncate-radius) + +(defun counsel--git-log-format-function (str) + (let ((counsel-yank-pop-truncate-radius 5)) + (counsel--yank-pop-format-function str))) + +;;;###autoload +(defun counsel-git-log () + "Call the \"git log --grep\" shell command." + (interactive) + (ivy-read "Grep log: " #'counsel-git-log-function + :dynamic-collection t + :action #'counsel-git-log-action + :caller 'counsel-git-log)) + +(ivy-configure 'counsel-git-log + :height 4 + :unwind-fn #'counsel-delete-process + :format-fn #'counsel--git-log-format-function) + +(add-to-list 'counsel-async-split-string-re-alist '(counsel-git-log . "^commit ")) +(add-to-list 'counsel-async-ignore-re-alist '(counsel-git-log . "^[ \n]*$")) + +;;; File +;;;; `counsel-find-file' + +(defvar counsel-find-file-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-DEL") #'counsel-up-directory) + (define-key map (kbd "C-") #'counsel-up-directory) + (define-key map (kbd "`") #'counsel-file-jump-from-find) + (define-key map (kbd "C-`") (ivy-make-magic-action #'counsel-find-file "b")) + (define-key map `[remap ,#'undo] #'counsel-find-file-undo) + map)) + +(defun counsel-file-jump-from-find () + "Switch to `counsel-file-jump' from `counsel-find-file'." + (interactive) + (ivy-quit-and-run + (counsel-file-jump ivy-text (ivy-state-directory ivy-last)))) + +(when (executable-find "git") + (add-to-list 'ivy-ffap-url-functions 'counsel-github-url-p) + (add-to-list 'ivy-ffap-url-functions 'counsel-emacs-url-p)) +(add-to-list 'ivy-ffap-url-functions 'counsel-url-expand) +(defun counsel-find-file-cd-bookmark-action (_) + "Reset `counsel-find-file' from selected directory." + (ivy-read "cd: " + (progn + (ivy--virtual-buffers) + (delete-dups + (mapcar (lambda (x) (file-name-directory (cdr x))) + ivy--virtual-buffers))) + :action (lambda (x) + (let ((default-directory (file-name-directory x))) + (counsel-find-file))))) + +(defcustom counsel-root-command "sudo" + "Command to gain root privileges." + :type 'string) + +(defun counsel-find-file-as-root (x) + "Find file X with root privileges." + (counsel-require-program counsel-root-command) + (let* ((host (file-remote-p x 'host)) + (file-name (format "/%s:%s:%s" + counsel-root-command + (or host "") + (expand-file-name + (if host + (file-remote-p x 'localname) + x))))) + ;; If the current buffer visits the same file we are about to open, + ;; replace the current buffer with the new one. + (if (eq (current-buffer) (get-file-buffer x)) + (find-alternate-file file-name) + (find-file file-name)))) + +(defun counsel--yes-or-no-p (fmt &rest args) + "Ask user a yes or no question created using FMT and ARGS. +If Emacs 26 user option `read-answer-short' is bound, use it to +choose between `yes-or-no-p' and `y-or-n-p'; otherwise default to +`yes-or-no-p'." + (funcall (if (and (boundp 'read-answer-short) + (cond ((eq read-answer-short t)) + ((eq read-answer-short 'auto) + (eq (symbol-function 'yes-or-no-p) 'y-or-n-p)))) + #'y-or-n-p + #'yes-or-no-p) + (apply #'format fmt args))) + +(defun counsel-find-file-copy (x) + "Copy file X." + ;; Autoloaded by `dired'. + (declare-function dired-copy-file "dired-aux") + (counsel--find-file-1 "Copy file to: " + ivy--directory + (lambda (new-name) + (dired-copy-file x new-name 1)) + 'counsel-find-file-copy)) + +(defun counsel-find-file-delete (x) + "Delete file X." + (defvar dired-recursive-deletes) + (declare-function dired-clean-up-after-deletion "dired") + (declare-function dired-delete-file "dired") + (when (or delete-by-moving-to-trash + ;; `dired-delete-file', which see, already prompts for directories + (eq t (car (file-attributes x))) + (counsel--yes-or-no-p "Delete %s? " x)) + (dired-delete-file x dired-recursive-deletes delete-by-moving-to-trash) + (dired-clean-up-after-deletion x) + (let ((win (and (not (eq ivy-exit 'done)) + (active-minibuffer-window)))) + (when win (with-selected-window win (ivy--cd ivy--directory)))))) + +(defun counsel-find-file-move (x) + "Move or rename file X." + ;; Autoloaded by `dired'. + (declare-function dired-rename-file "dired-aux") + (counsel--find-file-1 "Rename file to: " + ivy--directory + (lambda (new-name) + (dired-rename-file x new-name 1)) + 'counsel-find-file-move)) + +(defun counsel-find-file-mkdir-action (_x) + "Create a directory and any nonexistent parent dirs from `ivy-text'." + (let ((dir (file-name-as-directory + (expand-file-name ivy-text ivy--directory))) + (win (and (not (eq ivy-exit 'done)) + (active-minibuffer-window)))) + (make-directory dir t) + (when win (with-selected-window win (ivy--cd dir))))) + +(ivy-set-actions + 'counsel-find-file + '(("j" find-file-other-window "other window") + ("f" find-file-other-frame "other frame") + ("b" counsel-find-file-cd-bookmark-action "cd bookmark") + ("x" counsel-find-file-extern "open externally") + ("r" counsel-find-file-as-root "open as root") + ("R" find-file-read-only "read only") + ("l" find-file-literally "open literally") + ("k" counsel-find-file-delete "delete") + ("c" counsel-find-file-copy "copy file") + ("m" counsel-find-file-move "move or rename") + ("d" counsel-find-file-mkdir-action "mkdir"))) + +(defcustom counsel-find-file-at-point nil + "When non-nil, add file-at-point to the list of candidates." + :type 'boolean) + +(defcustom counsel-preselect-current-file nil + "When non-nil, preselect current file in list of candidates." + :type 'boolean) + +(defcustom counsel-find-file-ignore-regexp nil + "A regexp of files to ignore while in `counsel-find-file'. +These files are un-ignored if `ivy-text' matches them. The +common way to show all files is to start `ivy-text' with a dot. + +Example value: \"\\\\=`[#.]\\|[#~]\\\\='\". +This will hide temporary and lock files. +\\ +Choosing the dotfiles option, \"\\\\=`\\.\", might be convenient, +since you can still access the dotfiles if your input starts with +a dot. The generic way to toggle ignored files is \\[ivy-toggle-ignore], +but the leading dot is a lot faster." + :type `(choice + (const :tag "None" nil) + (const :tag "Dotfiles and Lockfiles" "\\(?:\\`\\|[/\\]\\)\\(?:[#.]\\)") + (const :tag "Ignored Extensions" + ,(concat (regexp-opt completion-ignored-extensions) "\\'")) + (regexp :tag "Regex"))) + +(defvar counsel--find-file-predicate nil + "When non-nil, `counsel--find-file-matcher' will use this predicate.") + +(defun counsel--find-file-matcher (regexp candidates) + "Return REGEXP matching CANDIDATES. +Skip some dotfiles unless `ivy-text' requires them." + (let ((res + (ivy--re-filter + regexp candidates + (lambda (re-str) + (lambda (x) + (string-match re-str (directory-file-name x))))))) + (when counsel--find-file-predicate + (let ((default-directory ivy--directory)) + (setq res (cl-remove-if-not counsel--find-file-predicate res)))) + (if (or (null ivy-use-ignore) + (null counsel-find-file-ignore-regexp) + (string-match-p counsel-find-file-ignore-regexp ivy-text)) + res + (or (cl-remove-if + (lambda (x) + (and + (string-match-p counsel-find-file-ignore-regexp x) + (not (member x ivy-extra-directories)))) + res) + res)))) + +(declare-function ffap-guesser "ffap") + +(defvar counsel-find-file-speedup-remote t + "Speed up opening remote files by disabling `find-file-hook' for them.") + +(defcustom counsel-find-file-extern-extensions '("mp4" "mkv" "xlsx") + "List of extensions that make `counsel-find-file' use `counsel-find-file-extern'." + :type '(repeat string)) + +(defun counsel-find-file-action (x) + "Find file X." + (cond ((and counsel-find-file-speedup-remote + (file-remote-p ivy--directory)) + (let ((find-file-hook nil)) + (find-file (expand-file-name x ivy--directory)))) + ((member (file-name-extension x) counsel-find-file-extern-extensions) + (counsel-find-file-extern x)) + (t + (find-file (expand-file-name x ivy--directory))))) + +(defun counsel--preselect-file () + "Return candidate to preselect during filename completion. +The preselect behavior can be customized via user options +`counsel-find-file-at-point' and +`counsel-preselect-current-file', which see." + (or + (when counsel-find-file-at-point + (require 'ffap) + (let ((f (ffap-guesser))) + (when (and f (not (ivy-ffap-url-p f))) + (expand-file-name f)))) + (and counsel-preselect-current-file + buffer-file-name + (file-name-nondirectory buffer-file-name)))) + +(defun counsel--find-file-1 (prompt initial-input action caller) + (declare-function dired-current-directory "dired") + (let ((default-directory + (if (derived-mode-p 'dired-mode) + (dired-current-directory) + default-directory))) + (ivy-read prompt #'read-file-name-internal + :matcher #'counsel--find-file-matcher + :initial-input initial-input + :action action + :preselect (counsel--preselect-file) + :require-match 'confirm-after-completion + :history 'file-name-history + :keymap counsel-find-file-map + :caller caller))) + +;;;###autoload +(defun counsel-find-file (&optional initial-input initial-directory) + "Forward to `find-file'. +When INITIAL-INPUT is non-nil, use it in the minibuffer during completion." + (interactive) + (require 'dired) + (defvar tramp-archive-enabled) + (let ((tramp-archive-enabled nil) + (default-directory (or initial-directory default-directory))) + (counsel--find-file-1 "Find file: " initial-input + #'counsel-find-file-action + 'counsel-find-file))) + +(ivy-configure 'counsel-find-file + :parent 'read-file-name-internal + :occur #'counsel-find-file-occur) + +(defvar counsel-find-file-occur-cmd "ls -a | %s | xargs -d '\\n' ls -d --group-directories-first" + "Format string for `counsel-find-file-occur'.") + +(defvar counsel-find-file-occur-use-find (not (eq system-type 'gnu/linux)) + "When non-nil, `counsel-find-file-occur' will use \"find\" as the base cmd.") + +(defun counsel--expand-ls (cmd) + "Expand CMD that ends in \"ls\" with switches." + (concat cmd " " counsel-dired-listing-switches " | sed -e \"s/^/ /\"")) + +(defvar counsel-file-name-filter-alist + '(("ag -i '%s'" . t) + ("ack -i '%s'" . t) + ("perl -ne '/(.*%s.*)/i && print \"$1\\n\";'" . t) + ("grep -i -E '%s'")) + "Alist of file name filtering commands. +The car is a shell command and the cdr is t when the shell +command supports look-arounds. The executable for the commands +will be checked for existence via `executable-find'. The first +one that exists will be used.") + +(defun counsel--file-name-filter (&optional use-ignore) + "Return a command that filters a file list to match ivy candidates. +If USE-IGNORE is non-nil, try to generate a command that respects +`counsel-find-file-ignore-regexp'." + (let ((regex ivy--old-re)) + (if (= 0 (length regex)) + "cat" + (let ((filter-cmd (cl-find-if + (lambda (x) + (executable-find + (car (split-string (car x))))) + counsel-file-name-filter-alist)) + cmd) + (when (and use-ignore ivy-use-ignore + counsel-find-file-ignore-regexp + (cdr filter-cmd) + (not (string-match-p counsel-find-file-ignore-regexp ivy-text)) + (not (string-match-p counsel-find-file-ignore-regexp + (or (car ivy--old-cands) "")))) + (let ((ignore-re (list (counsel--elisp-to-pcre + counsel-find-file-ignore-regexp)))) + (setq regex (if (stringp regex) + (list ignore-re (cons regex t)) + (cons ignore-re regex))))) + (setq cmd (format (car filter-cmd) + (counsel--elisp-to-pcre regex (cdr filter-cmd)))) + (if (string-suffix-p "csh" shell-file-name) + (ivy--string-replace "?!" "?\\!" cmd) + cmd))))) + +(defun counsel--occur-cmd-find () + (let ((cmd (format + "find . -maxdepth 1 | %s | xargs -I {} find {} -maxdepth 0 -ls" + (counsel--file-name-filter t)))) + (concat + (counsel--cmd-to-dired-by-type "d" cmd) + " && " + (counsel--cmd-to-dired-by-type "f" cmd)))) + +(defun counsel--cmd-to-dired-by-type (type cmd) + (let ((exclude-dots + (unless (string-prefix-p "." ivy-text) + " | grep -v '/\\.'"))) + (ivy--string-replace + " | grep" + (concat " -type " type exclude-dots " | grep") cmd))) + +(defun counsel-find-file-occur (&optional _cands) + (require 'find-dired) + (cd ivy--directory) + (if counsel-find-file-occur-use-find + (counsel-cmd-to-dired + (counsel--occur-cmd-find) + 'find-dired-filter) + (counsel-cmd-to-dired + (counsel--expand-ls + (format counsel-find-file-occur-cmd + (if (ivy--string-search "grep" counsel-find-file-occur-cmd) + ;; for backwards compatibility + (counsel--elisp-to-pcre ivy--old-re) + (counsel--file-name-filter t))))))) + +(defvar counsel-up-directory-level t + "Control whether `counsel-up-directory' goes up a level or always a directory. + +If non-nil, then `counsel-up-directory' will remove the final level of the path. +For example: /a/long/path/file.jpg => /a/long/path/ + /a/long/path/ => /a/long/ + +If nil, then `counsel-up-directory' will go up a directory. +For example: /a/long/path/file.jpg => /a/long/ + /a/long/path/ => /a/long/") + +(defun counsel-up-directory () + "Go to the parent directory preselecting the current one. + +If the current directory is remote and it's not possible to go up any +further, make the remote prefix editable. + +See variable `counsel-up-directory-level'." + (interactive) + (let* ((cur-dir (directory-file-name (expand-file-name ivy--directory))) + (up-dir (file-name-directory cur-dir))) + (if (and (file-remote-p cur-dir) (string-equal cur-dir up-dir)) + (progn + ;; make the remote prefix editable + (setq ivy--old-cands nil) + (setq ivy--old-re nil) + (ivy-set-index 0) + (setq ivy--directory "") + (setq ivy--all-candidates nil) + (ivy-set-text "") + (delete-minibuffer-contents) + (insert up-dir)) + (if (and counsel-up-directory-level (not (string= ivy-text ""))) + (delete-region (line-beginning-position) (line-end-position)) + (ivy--cd up-dir) + (setf (ivy-state-preselect ivy-last) + (file-name-as-directory (file-name-nondirectory cur-dir))))))) + +(defun counsel-down-directory () + "Descend into the current directory." + (interactive) + (ivy--directory-enter)) + +(defun counsel-find-file-undo () + (interactive) + (if (string= ivy-text "") + (let ((dir (progn + (pop ivy--directory-hist) + (pop ivy--directory-hist)))) + (when dir + (ivy--cd dir))) + (undo))) + +(defun counsel-at-git-issue-p () + "When point is at an issue in a Git-versioned file, return the issue string." + (and (looking-at "#[0-9]+") + (save-match-data + (or (eq (vc-backend buffer-file-name) 'Git) + (memq major-mode '(magit-commit-mode vc-git-log-view-mode)) + (bound-and-true-p magit-commit-mode))) + (match-string-no-properties 0))) + +(defun counsel-github-url-p () + "Return a Github issue URL at point." + (when (counsel-require-program "git" t) + (let ((url (counsel-at-git-issue-p))) + (when url + (let ((origin (shell-command-to-string + "git remote get-url origin")) + user repo) + (cond ((string-match "\\`git@github.com:\\([^/]+\\)/\\(.*\\)\\.git$" + origin) + (setq user (match-string 1 origin)) + (setq repo (match-string 2 origin))) + ((string-match "\\`https://github.com/\\([^/]+\\)/\\(.*\\)$" + origin) + (setq user (match-string 1 origin)) + (setq repo (match-string 2 origin)))) + (when user + (setq url (format "https://github.com/%s/%s/issues/%s" + user repo (substring url 1))))))))) + +(defun counsel-emacs-url-p () + "Return a Debbugs issue URL at point." + (let ((url (and (counsel-require-program "git" t) + (counsel-at-git-issue-p)))) + (when url + (let ((origin (shell-command-to-string "git remote get-url origin"))) + (when (string-match-p "git.sv.gnu.org:/srv/git/emacs.git" origin) + (format "https://bugs.gnu.org/%s" (substring url 1))))))) + +(defvar counsel-url-expansions-alist nil + "Map of regular expressions to expansions. + +The value of this variable is a list of pairs (REGEXP . FORMAT). + +`counsel-url-expand' expands the word at point according to +FORMAT for the first matching REGEXP. FORMAT can be either a +string or a function. If it is a string, it is used as the +format string for the function `format', with the word at point +as the next argument. If it is a function, it is called with the +word at point as the sole argument. + +For example, a pair of the form: + \\='(\"\\\\\\=`BSERV-[[:digit:]]+\\\\\\='\" . + \"https://jira.atlassian.com/browse/%s\") +expands to the URL `https://jira.atlassian.com/browse/BSERV-100' +when the word at point is \"BSERV-100\". + +If FORMAT is a function, more powerful transformations are +possible. As an example, + \\='(\"\\\\\\=`issue\\\\([[:digit:]]+\\\\)\\\\\\='\" . + (lambda (word) + (concat \"https://bugs.gnu.org/\" (match-string 1 word)))) +trims the \"issue\" prefix from the word at point before creating +the URL.") + +(defun counsel-url-expand () + "Expand word at point using `counsel-url-expansions-alist'. +The first pair in the list whose regexp matches the word at point +will be expanded according to its format. This function is +intended to be used in `ivy-ffap-url-functions' to browse the +result as a URL." + (let ((word-at-point (current-word))) + (when word-at-point + (cl-some + (lambda (pair) + (let ((regexp (car pair)) + (formatter (cdr pair))) + (when (string-match regexp word-at-point) + (if (functionp formatter) + (funcall formatter word-at-point) + (format formatter word-at-point))))) + counsel-url-expansions-alist)))) + +;;;; `counsel-dired' + +;;;###autoload +(defun counsel-dired (&optional initial-input) + "Forward to `dired'. +When INITIAL-INPUT is non-nil, use it in the minibuffer during completion." + (interactive) + (require 'dired) + (let ((counsel--find-file-predicate #'file-directory-p)) + (counsel--find-file-1 + "Dired (directory): " initial-input + (lambda (d) (dired (expand-file-name d))) + 'counsel-dired))) + +(ivy-configure 'counsel-dired + :parent 'read-file-name-internal) + +;;;; `counsel-recentf' + +(defvar recentf-list) +(declare-function recentf-mode "recentf") + +(defcustom counsel-recentf-include-xdg-list nil + "Include recently used files listed by XDG-compliant environments. +Examples of such environments are GNOME and KDE. See the URL +`https://www.freedesktop.org/wiki/Specifications/desktop-bookmark-spec'." + :type 'boolean + :link '(url-link "\ +https://www.freedesktop.org/wiki/Specifications/desktop-bookmark-spec")) + +;;;###autoload +(defun counsel-recentf () + "Find a file on `recentf-list'." + (interactive) + (recentf-mode) + (ivy-read "Recentf: " (counsel-recentf-candidates) + :action (lambda (f) + (with-ivy-window + (find-file f))) + :require-match t + :caller 'counsel-recentf)) + +(ivy-set-actions + 'counsel-recentf + `(("j" find-file-other-window "other window") + ("f" find-file-other-frame "other frame") + ("x" counsel-find-file-extern "open externally") + ("d" ,(lambda (file) (setq recentf-list (delete file recentf-list))) + "delete from recentf"))) + +(defun counsel-recentf-candidates () + "Return candidates for `counsel-recentf'. + +When `counsel-recentf-include-xdg-list' is non-nil, also include +the files in said list, sorting the combined list by file access +time." + (if (and counsel-recentf-include-xdg-list + (>= emacs-major-version 26)) + (delete-dups + (sort (nconc (mapcar #'substring-no-properties recentf-list) + (counsel--recentf-get-xdg-recent-files)) + (lambda (file1 file2) + (cond ((file-remote-p file1) + nil) + ((file-remote-p file2)) + (t + ;; Added in Emacs 26.1. + (declare-function file-attribute-access-time "files" + (attributes)) + (time-less-p (file-attribute-access-time + (file-attributes file2)) + (file-attribute-access-time + (file-attributes file1)))))))) + (mapcar #'substring-no-properties recentf-list))) + +(defalias 'counsel--xml-parse-region + (if (cond ((fboundp 'libxml-available-p) + ;; Added in Emacs 27.1. + (libxml-available-p)) + ((fboundp 'libxml-parse-xml-region) + ;; Checking for `fboundp' is not enough on Windows, where it + ;; will return non-nil even if the library is not installed. + (with-temp-buffer + (insert "") + (libxml-parse-xml-region (point-min) (point-max))))) + (lambda (&optional beg end) + (libxml-parse-xml-region (or beg (point-min)) (or end (point-max)))) + #'xml-parse-region) + "Compatibility shim for `libxml-parse-xml-region'. +For convenience, BEG and END default to `point-min' and +`point-max', respectively. + +\(fn &optional BEG END)") + +(defun counsel--recentf-get-xdg-recent-files () + "Return list of XDG recent files. + +This information is parsed from the file \"recently-used.xbel\", +which lists both files and directories, under `xdg-data-home'. +This function uses the `dom' library from Emacs 25.1 or later." + (unless (eval-and-compile (require 'dom nil t)) + (user-error "This function requires Emacs 25.1 or later")) + (declare-function dom-by-tag "dom" (dom tag)) + (let ((file-of-recent-files + (expand-file-name "recently-used.xbel" (counsel--xdg-data-home)))) + (unless (file-readable-p file-of-recent-files) + (user-error "List of XDG recent files not found: %s" + file-of-recent-files)) + (when (fboundp 'dom-attr) ;; Pacify Emacs 24. + (cl-mapcan (lambda (bookmark-node) + (let* ((file (dom-attr bookmark-node 'href)) + (file (string-remove-prefix "file://" file)) + (file (url-unhex-string file t)) + (file (decode-coding-string file 'utf-8 t))) + (and (file-exists-p file) + (list file)))) + (let ((dom (with-temp-buffer + (insert-file-contents file-of-recent-files) + (counsel--xml-parse-region)))) + (nreverse (dom-by-tag dom 'bookmark))))))) + +(defun counsel-buffer-or-recentf-candidates () + "Return candidates for `counsel-buffer-or-recentf'." + (recentf-mode) + (let ((buffers (delq nil (mapcar #'buffer-file-name (buffer-list))))) + (nconc + buffers + (cl-remove-if (lambda (f) (member f buffers)) + (counsel-recentf-candidates))))) + +;;;###autoload +(defun counsel-buffer-or-recentf () + "Find a buffer visiting a file or file on `recentf-list'." + (interactive) + (ivy-read "Buffer File or Recentf: " (counsel-buffer-or-recentf-candidates) + :action (lambda (s) + (with-ivy-window + (if (bufferp s) + (switch-to-buffer s) + (find-file s)))) + :require-match t + :caller 'counsel-buffer-or-recentf)) + +(ivy-configure 'counsel-buffer-or-recentf + :display-transformer-fn #'counsel-buffer-or-recentf-transformer) + +(ivy-set-actions + 'counsel-buffer-or-recentf + '(("j" find-file-other-window "other window") + ("f" find-file-other-frame "other frame") + ("x" counsel-find-file-extern "open externally"))) + +(defun counsel-buffer-or-recentf-transformer (var) + "Propertize VAR if it's a buffer visiting a file." + (if (member var (mapcar #'buffer-file-name (buffer-list))) + (ivy-append-face var 'ivy-highlight-face) + var)) + +;;;; `counsel-bookmark' + +(defcustom counsel-bookmark-avoid-dired nil + "If non-nil, open directory bookmarks with `counsel-find-file'. +By default `counsel-bookmark' opens a dired buffer for directories." + :type 'boolean) + +(defvar bookmark-alist) +(declare-function bookmark-location "bookmark") +(declare-function bookmark-all-names "bookmark") +(declare-function bookmark-get-filename "bookmark") +(declare-function bookmark-maybe-load-default-file "bookmark") + +;;;###autoload +(defun counsel-bookmark () + "Forward to `bookmark-jump' or `bookmark-set' if bookmark doesn't exist." + (interactive) + (require 'bookmark) + (ivy-read "Create or jump to bookmark: " + (bookmark-all-names) + :history 'bookmark-history + :action (lambda (x) + (cond ((and counsel-bookmark-avoid-dired + (member x (bookmark-all-names)) + (file-directory-p (bookmark-location x))) + (with-ivy-window + (let ((default-directory (bookmark-location x))) + (counsel-find-file)))) + ((member x (bookmark-all-names)) + (with-ivy-window + (bookmark-jump x))) + (t + (bookmark-set x)))) + :caller 'counsel-bookmark)) + +(defun counsel--apply-bookmark-fn (fn) + "Return a function applying FN to a bookmark's location." + (lambda (bookmark) + (funcall fn (bookmark-location bookmark)))) + +(ivy-set-actions + 'counsel-bookmark + `(("j" bookmark-jump-other-window "other window") + ("d" bookmark-delete "delete") + ("e" bookmark-rename "edit") + ("s" bookmark-set "overwrite") + ("x" ,(counsel--apply-bookmark-fn #'counsel-find-file-extern) + "open externally") + ("r" ,(counsel--apply-bookmark-fn #'counsel-find-file-as-root) + "open as root"))) + +;;;; `counsel-bookmarked-directory' + +(defun counsel-bookmarked-directory--candidates () + "Get a list of bookmarked directories sorted by file path." + (bookmark-maybe-load-default-file) + (sort (cl-delete-if-not + #'ivy--dirname-p + (delq nil (mapcar #'bookmark-get-filename bookmark-alist))) + #'string<)) + +;;;###autoload +(defun counsel-bookmarked-directory () + "Ivy interface for bookmarked directories. + +With a prefix argument, this command creates a new bookmark which points to the +current value of `default-directory'." + (interactive) + (require 'bookmark) + (ivy-read "Bookmarked directory: " + (counsel-bookmarked-directory--candidates) + :caller 'counsel-bookmarked-directory + :action #'dired)) + +(ivy-set-actions 'counsel-bookmarked-directory + `(("j" ,#'dired-other-window "other window") + ("x" ,#'counsel-find-file-extern "open externally") + ("r" ,#'counsel-find-file-as-root "open as root") + ("f" ,(lambda (dir) + (let ((default-directory dir)) + (call-interactively #'find-file))) + "find-file"))) + +;;;; `counsel-file-register' + +;;;###autoload +(defun counsel-file-register () + "Search file in register. + +You cannot use Emacs' normal register commands to create file +registers. Instead you must use the `set-register' function like +so: `(set-register ?i \"/home/eric/.emacs.d/init.el\")'. Now you +can use `C-x r j i' to open that file." + (interactive) + (ivy-read "File Register: " + ;; Use the `register-alist' variable to filter out file + ;; registers. Each entry for a file register will have the + ;; following layout: + ;; + ;; (NUMBER 'file . "string/path/to/file") + ;; + ;; So we go through each entry and see if the `cadr' is + ;; `eq' to the symbol `file'. If so then add the filename + ;; (`cddr') which `ivy-read' will use for its choices. + (mapcar (lambda (register-alist-entry) + (if (eq 'file (cadr register-alist-entry)) + (cddr register-alist-entry))) + register-alist) + :require-match t + :history 'counsel-file-register + :caller 'counsel-file-register + :action (lambda (register-file) + (with-ivy-window (find-file register-file))))) + +(ivy-configure 'counsel-file-register + :sort-fn #'ivy-string<) + +(ivy-set-actions + 'counsel-file-register + '(("j" find-file-other-window "other window"))) + +;;;; `counsel-locate' + +(defcustom counsel-locate-cmd (cond ((memq system-type '(darwin berkeley-unix)) + #'counsel-locate-cmd-noregex) + ((and (eq system-type 'windows-nt) + (executable-find "es.exe")) + #'counsel-locate-cmd-es) + (t + #'counsel-locate-cmd-default)) + "The function for producing a `locate' command string from the input. + +The function takes a string - the current input, and returns a +string - the full shell command to run." + :type '(choice + (const :tag "Default" counsel-locate-cmd-default) + (const :tag "No regex" counsel-locate-cmd-noregex) + (const :tag "mdfind" counsel-locate-cmd-mdfind) + (const :tag "everything" counsel-locate-cmd-es) + (function :tag "Custom"))) + +(ivy-set-actions + 'counsel-locate + '(("x" counsel-locate-action-extern "xdg-open") + ("r" counsel-find-file-as-root "open as root") + ("d" counsel-locate-action-dired "dired"))) + +(defvar counsel-locate-history nil + "History for `counsel-locate'.") + +;;;###autoload +(defun counsel-locate-action-extern (x) + "Pass X to `xdg-open' or equivalent command via the shell." + (interactive "FFile: ") + (if (and (eq system-type 'windows-nt) + (fboundp 'w32-shell-execute)) + (w32-shell-execute "open" x) + (call-process-shell-command (format "%s %s" + (cl-case system-type + (darwin "open") + (cygwin "cygstart") + (t "xdg-open")) + (shell-quote-argument x)) + nil 0))) + +(defalias 'counsel-find-file-extern #'counsel-locate-action-extern) + +(eval-and-compile + ;; Autoloaded by `dired' since Emacs 28. + (unless (fboundp 'dired-jump) + (autoload 'dired-jump "dired-x" nil t))) + +(defun counsel-locate-action-dired (x) + "Use `dired-jump' on X." + (dired-jump nil x)) + +(defvar locate-command) + +(defun counsel-locate-cmd-default (input) + "Return a `locate' shell command based on regexp INPUT. +This uses the user option `locate-command' from the `locate' +library, which see." + (counsel-require-program locate-command) + (format "%s -i --regex %s" + locate-command + (shell-quote-argument + (counsel--elisp-to-pcre + (ivy--regex input))))) + +(defun counsel-locate-cmd-noregex (input) + "Return a `locate' shell command based on INPUT. +This uses the user option `locate-command' from the `locate' +library, which see." + (counsel-require-program locate-command) + (format "%s -i %s" + locate-command + (shell-quote-argument input))) + +(defun counsel-locate-cmd-mdfind (input) + "Return a `mdfind' shell command based on INPUT." + (counsel-require-program "mdfind") + (format "mdfind -name %s 2>%s" + (shell-quote-argument input) + (shell-quote-argument (counsel--null-device)))) + +(defun counsel-locate-cmd-es (input) + "Return a `es' shell command based on INPUT." + (defvar w32-ansi-code-page) + (counsel-require-program "es.exe") + (let ((raw-string (format "es.exe -i -p -r %s" + (counsel--elisp-to-pcre + (ivy--regex input t))))) + ;; W32 doesn't use Unicode by default, so we encode search command + ;; to local codepage to support searching file names containing + ;; non-ASCII characters. + (if (and (eq system-type 'windows-nt) + (boundp 'w32-ansi-code-page)) + (encode-coding-string raw-string + (intern (format "cp%d" w32-ansi-code-page))) + raw-string))) + +(defun counsel-locate-function (input) + "Call a \"locate\" style shell command with INPUT." + (or + (ivy-more-chars) + (progn + (counsel--async-command + (funcall counsel-locate-cmd input)) + '("" "working...")))) + +(defcustom counsel-locate-db-path "~/.local/mlocate.db" + "Location where to put the locatedb in case your home folder is encrypted." + :type 'file) + +(defun counsel-file-stale-p (fname seconds) + "Return non-nil if FNAME was modified more than SECONDS ago." + (> (float-time (time-since (nth 5 (file-attributes fname)))) + seconds)) + +(defun counsel--locate-updatedb () + (when (file-exists-p "~/.Private") + (let ((db-fname (expand-file-name counsel-locate-db-path))) + (setenv "LOCATE_PATH" db-fname) + (when (or (not (file-exists-p db-fname)) + (counsel-file-stale-p db-fname 60)) + (message "Updating %s..." db-fname) + (counsel--command + "updatedb" "-l" "0" "-o" db-fname "-U" (expand-file-name "~")))))) + +;;;###autoload +(defun counsel-locate (&optional initial-input) + "Call a \"locate\" style shell command. +INITIAL-INPUT can be given as the initial minibuffer input." + (interactive) + ;; For `locate-command', which is honored in some options of `counsel-locate-cmd'. + (require 'locate) + (counsel--locate-updatedb) + (ivy-read "Locate: " #'counsel-locate-function + :initial-input initial-input + :dynamic-collection t + :history 'counsel-locate-history + :action (lambda (file) + (when file + (with-ivy-window + (find-file + (concat (file-remote-p default-directory) file))))) + :caller 'counsel-locate)) + +(ivy-configure 'counsel-locate + :unwind-fn #'counsel-delete-process + :exit-codes '(1 "Nothing found")) + +;;;; `counsel-tracker' + +(defun counsel-tracker-function (input) + "Call the \"tracker\" shell command with INPUT." + (or + (ivy-more-chars) + (progn + (counsel--async-command + (format + "tracker sparql -q \"SELECT ?url WHERE { ?s a nfo:FileDataObject ; nie:url ?url . FILTER (STRSTARTS (?url, 'file://$HOME/')) . FILTER regex(?url, '%s') }\" | tail -n +2 | head -n -1" + (counsel--elisp-to-pcre (funcall ivy--regex-function input)))) + '("" "working...")))) + +(defun counsel-tracker-transformer (str) + (if (string-match "file:///" str) + (decode-coding-string (url-unhex-string (substring str 9)) 'utf-8) + str)) + +;;;###autoload +(defun counsel-tracker () + (interactive) + (ivy-read "Tracker: " 'counsel-tracker-function + :dynamic-collection t + :action (lambda (s) (find-file (counsel-tracker-transformer s))) + :caller 'counsel-tracker)) + +(ivy-configure 'counsel-tracker + :display-transformer-fn #'counsel-tracker-transformer + :unwind-fn #'counsel-delete-process) + +;;;; `counsel-fzf' + +(defvar counsel-fzf-cmd "fzf -f \"%s\"" + "Command for `counsel-fzf'.") + +(defvar counsel--fzf-dir nil + "Store the base fzf directory.") + +(defvar counsel-fzf-dir-function #'counsel-fzf-dir-function-projectile + "Function that returns a directory for fzf to use.") + +(defun counsel-fzf-dir-function-projectile () + (if (and + (fboundp 'projectile-project-p) + (fboundp 'projectile-project-root) + (projectile-project-p)) + (projectile-project-root) + default-directory)) + +(defun counsel-fzf-function (str) + (let ((default-directory counsel--fzf-dir)) + (setq ivy--old-re (ivy--regex-fuzzy str)) + (counsel--async-command + (format counsel-fzf-cmd str))) + nil) + +;;;###autoload +(defun counsel-fzf (&optional initial-input initial-directory fzf-prompt) + "Open a file using the fzf shell command. +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search. +FZF-PROMPT, if non-nil, is passed as `ivy-read' prompt argument." + (interactive + (let ((fzf-basename (car (split-string counsel-fzf-cmd)))) + (list nil + (when current-prefix-arg + (counsel-read-directory-name (concat + fzf-basename + " in directory: ")))))) + (counsel-require-program counsel-fzf-cmd) + (setq counsel--fzf-dir + (or initial-directory + (funcall counsel-fzf-dir-function))) + (ivy-read (or fzf-prompt "fzf: ") + #'counsel-fzf-function + :initial-input initial-input + :re-builder #'ivy--regex-fuzzy + :dynamic-collection t + :action #'counsel-fzf-action + :caller 'counsel-fzf)) + +(ivy-configure 'counsel-fzf + :occur #'counsel-fzf-occur + :unwind-fn #'counsel-delete-process + :exit-codes '(1 "Nothing found")) + +(defun counsel-fzf-action (x) + "Find file X in current fzf directory." + (with-ivy-window + (let ((default-directory counsel--fzf-dir)) + (find-file x)))) + +(defun counsel-fzf-occur (&optional _cands) + "Occur function for `counsel-fzf' using `counsel-cmd-to-dired'." + (cd counsel--fzf-dir) + (counsel-cmd-to-dired + (counsel--expand-ls + (format + "%s --print0 | xargs -0 ls" + (format counsel-fzf-cmd ivy-text))))) + +(ivy-set-actions + 'counsel-fzf + '(("x" counsel-locate-action-extern "xdg-open") + ("d" counsel-locate-action-dired "dired"))) + +;;;; `counsel-dpkg' + +;;;###autoload +(defun counsel-dpkg () + "Call the \"dpkg\" shell command." + (interactive) + (counsel-require-program "dpkg") + (let ((cands (mapcar + (lambda (x) + (let ((y (split-string x " +"))) + (cons (format "%-40s %s" + (ivy--truncate-string + (nth 1 y) 40) + (nth 4 y)) + (mapconcat #'identity y " ")))) + (split-string + (shell-command-to-string "dpkg -l | tail -n+6") "\n" t)))) + (ivy-read "dpkg: " cands + :action (lambda (x) + (message (cdr x))) + :caller 'counsel-dpkg))) + +;;;; `counsel-rpm' + +;;;###autoload +(defun counsel-rpm () + "Call the \"rpm\" shell command." + (interactive) + (counsel-require-program "rpm") + (let ((cands (mapcar + (lambda (x) + (let ((y (split-string x "|"))) + (cons (format "%-40s %s" + (ivy--truncate-string + (nth 0 y) 40) + (nth 1 y)) + (mapconcat #'identity y " ")))) + (split-string + (shell-command-to-string "rpm -qa --qf \"%{NAME}|%{SUMMARY}\\n\"") "\n" t)))) + (ivy-read "rpm: " cands + :action (lambda (x) + (message (cdr x))) + :caller 'counsel-rpm))) + +(defun counsel--find-return-list (args) + (unless (listp args) + (user-error + "`counsel-file-jump-args' is a list now; please customize accordingly")) + (counsel--call + (cons find-program args) + (lambda () + (let (files) + (goto-char (point-min)) + (while (< (point) (point-max)) + (when (looking-at "\\./") + (goto-char (match-end 0))) + (push (buffer-substring (point) (line-end-position)) files) + (beginning-of-line 2)) + (nreverse files))))) + +(defcustom counsel-file-jump-args (split-string ". -name .git -prune -o -type f -print") + "Arguments for the `find-command' when using `counsel-file-jump'." + :type '(repeat string)) + +;;;; `counsel-file-jump' + +(defvar counsel-file-jump-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "`") #'counsel-find-file-from-jump) + map) + "Key bindings to be used when in a file-jump minibuffer.") + +(defun counsel-find-file-from-jump () + "Switch to `counsel-find-file' from `counsel-file-jump'." + (interactive) + (ivy-quit-and-run + (counsel-find-file ivy-text (ivy-state-directory ivy-last)))) + +;;;###autoload +(defun counsel-file-jump (&optional initial-input initial-directory) + "Jump to a file below the current directory. +List all files within the current directory or any of its sub-directories. +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search." + (interactive + (list nil + (when current-prefix-arg + (counsel-read-directory-name "From directory: ")))) + (counsel-require-program find-program) + (let ((default-directory (or initial-directory default-directory))) + (ivy-read "Find file: " + (counsel--find-return-list counsel-file-jump-args) + :matcher #'counsel--find-file-matcher + :initial-input initial-input + :action #'find-file + :preselect (counsel--preselect-file) + :require-match 'confirm-after-completion + :history 'file-name-history + :keymap counsel-file-jump-map + :caller 'counsel-file-jump))) + +(ivy-set-actions + 'counsel-file-jump + `(("d" ,(lambda (x) + (dired (or (file-name-directory x) default-directory))) + "open in dired"))) + +;;;; `counsel-dired-jump' + +(defcustom counsel-dired-jump-args (split-string ". -name .git -prune -o -type d -print") + "Arguments for the `find-command' when using `counsel-dired-jump'." + :type '(repeat string)) + +;;;###autoload +(defun counsel-dired-jump (&optional initial-input initial-directory) + "Jump to a directory (see `dired-jump') below the current directory. +List all sub-directories within the current directory. +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search." + (interactive + (list nil + (when current-prefix-arg + (counsel-read-directory-name "From directory: ")))) + (counsel-require-program find-program) + (let ((default-directory (or initial-directory default-directory))) + (ivy-read "Find directory: " + (cdr + (counsel--find-return-list counsel-dired-jump-args)) + :matcher #'counsel--find-file-matcher + :initial-input initial-input + :action (lambda (d) (dired-jump nil (expand-file-name d))) + :history 'file-name-history + :keymap counsel-find-file-map + :caller 'counsel-dired-jump))) + +;;; Grep +;;;; `counsel-ag' + +(defvar counsel-ag-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-l") #'ivy-call-and-recenter) + (define-key map (kbd "M-q") #'counsel-git-grep-query-replace) + (define-key map (kbd "C-'") #'swiper-avy) + (define-key map (kbd "C-x C-d") #'counsel-cd) + map)) + +(defcustom counsel-ag-base-command (list "ag" "--vimgrep" "%s") + "Template for default `counsel-ag' command. +The value should be either a list of strings, starting with the +`ag' executable file name and followed by its arguments, or a +single string describing a full `ag' shell command. + +If the command is specified as a list, `ag' is called directly +using `process-file'; otherwise, it is called as a shell command. +Calling `ag' directly avoids various shell quoting pitfalls, so +it is generally recommended. + +If the string \"%s\" appears as an element of the list, or as a +substring of the command string, it is replaced by any optional +`ag' arguments followed by the search regexp specified during the +`counsel-ag' session." + :package-version '(counsel . "0.14.0") + :type '(choice (repeat :tag "Command list to call directly" string) + (string :tag "Shell command"))) + +(defvar counsel-ag-command nil) + +(defvar counsel--grep-tool-look-around t) + +(defvar counsel--regex-look-around nil) + +(defconst counsel--command-args-separator " -- ") + +(defun counsel--split-command-args (arguments) + "Split ARGUMENTS into its switches and search-term parts. +Return pair of corresponding strings (SWITCHES . SEARCH-TERM)." + (if (string-match counsel--command-args-separator arguments) + (let ((args (substring arguments (match-end 0))) + (search-term (substring arguments 0 (match-beginning 0)))) + (if (string-prefix-p "-" arguments) + (cons search-term args) + (cons args search-term))) + (cons "" arguments))) + +(defun counsel--format-ag-command (extra-args needle) + "Construct a complete `counsel-ag-command' as a string. +EXTRA-ARGS is a string of the additional arguments. +NEEDLE is the search string." + (counsel--format counsel-ag-command + (if (listp counsel-ag-command) + (if (string-match " \\(--\\) " extra-args) + (counsel--format + (split-string (replace-match "%s" t t extra-args 1)) + needle) + (nconc (split-string extra-args) needle)) + (if (string-match " \\(--\\) " extra-args) + (replace-match needle t t extra-args 1) + (concat extra-args " " needle))))) + +(defun counsel--grep-regex (str) + (counsel--elisp-to-pcre + (setq ivy--old-re + (funcall (ivy-state-re-builder ivy-last) str)) + counsel--regex-look-around)) + +(defun counsel--ag-extra-switches (regex) + "Get additional switches needed for look-arounds." + (and (stringp counsel--regex-look-around) + ;; using look-arounds + (string-match-p "\\`\\^(\\?[=!]" regex) + (concat " " counsel--regex-look-around " "))) + +(defun counsel-ag-function (string) + "Grep in the current directory for STRING." + (let* ((command-args (counsel--split-command-args string)) + (search-term (cdr command-args))) + (or + (let ((ivy-text search-term)) + (ivy-more-chars)) + (let* ((default-directory (ivy-state-directory ivy-last)) + (regex (counsel--grep-regex search-term)) + (switches (concat (if (ivy--case-fold-p string) + " -i " + " -s ") + (counsel--ag-extra-switches regex) + (car command-args)))) + (counsel--async-command (counsel--format-ag-command + switches + (funcall (if (listp counsel-ag-command) #'identity + #'shell-quote-argument) + regex))) + nil)))) + +;;;###autoload +(cl-defun counsel-ag (&optional initial-input initial-directory extra-ag-args ag-prompt + &key caller) + "Grep for a string in a root directory using `ag'. + +By default, the root directory is the first directory containing +a .git subdirectory. + +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search. +EXTRA-AG-ARGS, if non-nil, is appended to `counsel-ag-base-command'. +AG-PROMPT, if non-nil, is passed as `ivy-read' prompt argument. +CALLER is passed to `ivy-read'. + +With a `\\[universal-argument]' prefix argument, prompt for INITIAL-DIRECTORY. +With a `\\[universal-argument] \\[universal-argument]' prefix argument, \ +prompt additionally for EXTRA-AG-ARGS." + (interactive) + (setq counsel-ag-command counsel-ag-base-command) + (setq counsel--regex-look-around counsel--grep-tool-look-around) + (counsel-require-program counsel-ag-command) + (let ((prog-name (car (if (listp counsel-ag-command) counsel-ag-command + (split-string counsel-ag-command)))) + (arg (prefix-numeric-value current-prefix-arg))) + (when (>= arg 4) + (setq initial-directory + (or initial-directory + (counsel-read-directory-name (concat + prog-name + " in directory: "))))) + (when (>= arg 16) + (setq extra-ag-args + (or extra-ag-args + (read-from-minibuffer (format "%s args: " prog-name))))) + (setq counsel-ag-command (counsel--format-ag-command (or extra-ag-args "") "%s")) + (let ((default-directory (or initial-directory + (counsel--git-root) + default-directory))) + (ivy-read (or ag-prompt + (concat prog-name ": ")) + #'counsel-ag-function + :initial-input initial-input + :dynamic-collection t + :keymap counsel-ag-map + :history 'counsel-git-grep-history + :action #'counsel-git-grep-action + :require-match t + :caller (or caller 'counsel-ag))))) + +(ivy-configure 'counsel-ag + :occur #'counsel-ag-occur + :unwind-fn #'counsel--grep-unwind + :display-transformer-fn #'counsel-git-grep-transformer + :grep-p t + :exit-codes '(1 "No matches found")) + +(defun counsel-read-directory-name (prompt &optional default) + "Read a directory name. +This is intended as a (partial) replacement for +`read-directory-name'." + (let ((counsel--find-file-predicate #'file-directory-p)) + (ivy-read prompt + #'read-file-name-internal + :matcher #'counsel--find-file-matcher + :def default + :history 'file-name-history + :keymap counsel-find-file-map + :caller 'counsel-read-directory-name))) + +(ivy-configure 'counsel-read-directory-name + :parent 'read-file-name-internal) + +(defun counsel-cd () + "Change the directory for the currently running Ivy grep-like command. +Works for `counsel-git-grep', `counsel-ag', etc." + (interactive) + (counsel-delete-process) + (let* ((input ivy-text) + (enable-recursive-minibuffers t) + (def-dir (buffer-file-name (ivy-state-buffer ivy-last))) + (def-dir (and def-dir (file-name-directory def-dir))) + (new-dir (counsel-read-directory-name "cd: " def-dir))) + (ivy-quit-and-run + (funcall (ivy-state-caller ivy-last) input new-dir)))) + +(defun counsel--grep-smart-case-flag () + (if (ivy--case-fold-p ivy-text) + "-i" + (if (and (stringp counsel-ag-base-command) + (string-prefix-p "pt" counsel-ag-base-command)) + "-S" + "-s"))) + +(defun counsel-grep-like-occur (cmd-template) + (unless (eq major-mode 'ivy-occur-grep-mode) + (ivy-occur-grep-mode) + (setq default-directory (ivy-state-directory ivy-last))) + (ivy-set-text + (let ((name (buffer-name))) + (if (string-match "\"\\(.*\\)\"" name) + (match-string 1 name) + (ivy-state-text ivy-occur-last)))) + (let* ((cmd + (if (functionp cmd-template) + (funcall cmd-template ivy-text) + (let* ((command-args (counsel--split-command-args ivy-text)) + (regex (counsel--grep-regex (cdr command-args))) + (extra-switches (counsel--ag-extra-switches regex)) + (all-args (append + (when (car command-args) + (split-string (car command-args))) + (when extra-switches + (split-string extra-switches)) + (list + (counsel--grep-smart-case-flag) + regex)))) + (if (stringp cmd-template) + (counsel--format + cmd-template + (mapconcat #'shell-quote-argument all-args " ")) + (cl-mapcan + (lambda (x) (if (string= x "%s") (copy-sequence all-args) (list x))) + cmd-template))))) + (cands (counsel--split-string + (if (stringp cmd) + (shell-command-to-string cmd) + (counsel--call cmd))))) + (swiper--occur-insert-lines (mapcar #'counsel--normalize-grep-match cands)))) + +(defun counsel-ag-occur (&optional _cands) + "Generate a custom occur buffer for `counsel-ag'." + (counsel-grep-like-occur + counsel-ag-command)) + +;;;; `counsel-pt' + +(defcustom counsel-pt-base-command "pt --nocolor --nogroup -e %s" + "Alternative to `counsel-ag-base-command' using pt." + :type 'string) + +;;;###autoload +(defun counsel-pt (&optional initial-input) + "Grep for a string in the current directory using pt. +INITIAL-INPUT can be given as the initial minibuffer input. +This uses `counsel-ag' with `counsel-pt-base-command' instead of +`counsel-ag-base-command'." + (interactive) + (let ((counsel-ag-base-command counsel-pt-base-command) + (counsel--grep-tool-look-around nil)) + (counsel-ag initial-input nil nil nil :caller 'counsel-pt))) + +(ivy-configure 'counsel-pt + :unwind-fn #'counsel--grep-unwind + :display-transformer-fn #'counsel-git-grep-transformer + :grep-p t) + +;;;; `counsel-ack' + +(defcustom counsel-ack-base-command + (concat + (file-name-nondirectory + (or (executable-find "ack-grep") "ack")) + " --nocolor --nogroup %s") + "Alternative to `counsel-ag-base-command' using ack." + :type 'string) + +;;;###autoload +(defun counsel-ack (&optional initial-input) + "Grep for a string in the current directory using ack. +INITIAL-INPUT can be given as the initial minibuffer input. +This uses `counsel-ag' with `counsel-ack-base-command' replacing +`counsel-ag-base-command'." + (interactive) + (let ((counsel-ag-base-command counsel-ack-base-command) + (counsel--grep-tool-look-around t)) + (counsel-ag + initial-input nil nil nil + :caller 'counsel-ack))) + +;;;; `counsel-rg' + +(defcustom counsel-rg-base-command + `("rg" + "--max-columns" "240" + "--with-filename" + "--no-heading" + "--line-number" + "--color" "never" + "%s" + ,@(and (memq system-type '(ms-dos windows-nt)) + (list "--path-separator" "/" "."))) + "Like `counsel-ag-base-command', but for `counsel-rg'. + +Note: don't use single quotes for the regexp." + :package-version '(counsel . "0.14.0") + :type '(choice (repeat :tag "Command list to call directly" string) + (string :tag "Shell command"))) + +(defun counsel--rg-targets () + "Return a list of files to operate on, based on `dired-mode' marks." + (when (derived-mode-p 'dired-mode) + (declare-function dired-get-marked-files "dired") + (declare-function dired-toggle-marks "dired") + (let ((files + (dired-get-marked-files 'no-dir nil nil t))) + (when (or (cdr files) + (when (ivy--string-search "*ivy-occur" (buffer-name)) + (dired-toggle-marks) + (setq files (dired-get-marked-files 'no-dir)) + (dired-toggle-marks) + t)) + (delq t files))))) + +;;;###autoload +(defun counsel-rg (&optional initial-input initial-directory extra-rg-args rg-prompt) + "Grep for a string in the current directory using `rg'. +INITIAL-INPUT can be given as the initial minibuffer input. +INITIAL-DIRECTORY, if non-nil, is used as the root directory for search. +EXTRA-RG-ARGS string, if non-nil, is appended to `counsel-rg-base-command'. +RG-PROMPT, if non-nil, is passed as `ivy-read' prompt argument. + +Example input with inclusion and exclusion file patterns: + require i -- -g*.el" + (interactive) + (let ((counsel-ag-base-command + (if (listp counsel-rg-base-command) + (append counsel-rg-base-command (counsel--rg-targets)) + (concat counsel-rg-base-command " " + (mapconcat #'shell-quote-argument (counsel--rg-targets) " ")))) + (counsel--grep-tool-look-around + (let ((rg (car (if (listp counsel-rg-base-command) counsel-rg-base-command + (split-string counsel-rg-base-command)))) + (switch "--pcre2")) + (and (eq 0 (call-process rg nil nil nil switch "--pcre2-version")) + switch)))) + (counsel-ag initial-input initial-directory extra-rg-args rg-prompt + :caller 'counsel-rg))) + +(ivy-configure 'counsel-rg + :occur #'counsel-ag-occur + :unwind-fn #'counsel--grep-unwind + :display-transformer-fn #'counsel-git-grep-transformer + :grep-p t + :exit-codes '(1 "No matches found")) + +;;;; `counsel-grep' + +(defvar counsel-grep-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-l") #'ivy-call-and-recenter) + (define-key map (kbd "M-q") #'swiper-query-replace) + (define-key map (kbd "C-'") #'swiper-avy) + map)) + +(defcustom counsel-grep-base-command "grep -E -n -e %s %s" + "Format string used by `counsel-grep' to build a shell command. +It should contain two %-sequences (see function `format') to be +substituted by the search regexp and file, respectively. Neither +%-sequence should be contained in single quotes." + :type 'string) + +(defvar counsel-grep-command nil) + +(defun counsel-grep-function (string) + "Grep in the current directory for STRING." + (or + (ivy-more-chars) + (let* ((regex (counsel--grep-regex string)) + (cmd (counsel--format + counsel-grep-command + (funcall (if (listp counsel-grep-command) #'identity + #'shell-quote-argument) + regex)))) + (counsel--async-command + (if (ivy--case-fold-p regex) + (if (listp cmd) (nconc (list (car cmd) "-i") (cdr cmd)) + (string-match " " cmd) + (replace-match " -i " nil nil cmd)) + cmd)) + nil))) + +(defvar counsel--grep-last-pos nil + "Store the last point and line that `counsel-grep-action' scrolled to. +This speeds up scrolling: instead of going to `point-min' and +`forward-line' with a huge arg (e.g. to scroll 50K lines), scroll +relative to the last position stored here.") + +(defun counsel-grep-action (x) + "Go to candidate X." + (with-ivy-window + (swiper--cleanup) + (let ((default-directory + (file-name-directory + (ivy-state-directory ivy-last))) + file-name line-number) + (when (cond ((string-match "\\`\\([0-9]+\\):\\(.*\\)\\'" x) + (setq file-name (buffer-file-name (ivy-state-buffer ivy-last))) + (setq line-number (match-string-no-properties 1 x))) + ((string-match "\\`\\([^:]+\\):\\([0-9]+\\):\\(.*\\)\\'" x) + (setq file-name (match-string-no-properties 1 x)) + (setq line-number (match-string-no-properties 2 x)))) + ;; If the file buffer is already open, just get it. Prevent doing + ;; `find-file', as that file could have already been opened using + ;; `find-file-literally'. + (with-current-buffer (or (get-file-buffer file-name) + (find-file file-name)) + (setq line-number (string-to-number line-number)) + (if (and counsel--grep-last-pos (= (point) (car counsel--grep-last-pos))) + (forward-line (- line-number (cdr counsel--grep-last-pos))) + (goto-char (point-min)) + (forward-line (1- line-number))) + (setq counsel--grep-last-pos (cons (point) line-number)) + (when (re-search-forward (ivy--regex ivy-text t) (line-end-position) t) + (when swiper-goto-start-of-match + (goto-char (match-beginning 0)))) + (run-hooks 'counsel-grep-post-action-hook) + (if (eq ivy-exit 'done) + (swiper--ensure-visible) + (isearch-range-invisible (line-beginning-position) + (line-end-position)) + (swiper--add-overlays (ivy--regex ivy-text)))))))) + +(defun counsel-grep-occur (&optional _cands) + "Generate a custom Occur buffer for `counsel-grep'." + (let ((file (buffer-file-name (ivy-state-buffer ivy-last)))) + (counsel-grep-like-occur + (format "grep -niE %%s %s %s" + (if file (shell-quote-argument (file-name-nondirectory file)) "") + (shell-quote-argument (counsel--null-device)))))) + +(defvar counsel-grep-history nil + "History for `counsel-grep'.") + +;;;###autoload +(defun counsel-grep (&optional initial-input) + "Grep for a string in the file visited by the current buffer. +When non-nil, INITIAL-INPUT is the initial search pattern." + (interactive) + (unless buffer-file-name + (user-error "Current buffer is not visiting a file")) + (counsel-require-program counsel-grep-base-command) + (setq counsel-grep-command + (counsel--format counsel-grep-base-command "%s" + (funcall (if (listp counsel-grep-base-command) #'identity + #'shell-quote-argument) + (file-name-nondirectory + buffer-file-name)))) + (let ((default-directory (file-name-directory buffer-file-name)) + (init-point (point)) + res) + (unwind-protect + (setq res (ivy-read "grep: " #'counsel-grep-function + :initial-input initial-input + :dynamic-collection t + :require-match t + :preselect + (when (< (- (line-end-position) (line-beginning-position)) 300) + (format "%d:%s" + (line-number-at-pos) + (regexp-quote + (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))))) + :keymap counsel-grep-map + :history 'counsel-grep-history + :re-builder #'ivy--regex + :action #'counsel-grep-action + :caller 'counsel-grep)) + (unless res + (goto-char init-point))))) + +(ivy-configure 'counsel-grep + :update-fn 'auto + :unwind-fn #'counsel--grep-unwind + :index-fn #'ivy-recompute-index-swiper-async + :occur #'counsel-grep-occur + :more-chars 2 + :grep-p t + :exit-codes '(1 "")) + +;;;###autoload +(defun counsel-grep-backward (&optional initial-input) + "Grep for a string in the file visited by the current buffer going +backward similar to `swiper-backward'. When non-nil, INITIAL-INPUT is +the initial search pattern." + (interactive) + (let ((ivy-index-functions-alist + '((counsel-grep . ivy-recompute-index-swiper-async-backward)))) + (counsel-grep initial-input))) + +;;;; `counsel-grep-or-swiper' + +(defcustom counsel-grep-swiper-limit 300000 + "Buffer size threshold for `counsel-grep-or-swiper'. +When the number of characters in a buffer exceeds this threshold, +`counsel-grep' will be used instead of `swiper'." + :type 'integer) + +(defcustom counsel-grep-use-swiper-p #'counsel-grep-use-swiper-p-default + "When this function returns non-nil, call `swiper', else `counsel-grep'." + :type '(choice + (const :tag "Rely on `counsel-grep-swiper-limit'." + counsel-grep-use-swiper-p-default) + (const :tag "Always use `counsel-grep'." ignore) + (function :tag "Custom"))) + +(defun counsel-grep-use-swiper-p-default () + (<= (buffer-size) + (/ counsel-grep-swiper-limit + (if (eq major-mode 'org-mode) 4 1)))) + +;;;###autoload +(defun counsel-grep-or-swiper (&optional initial-input) + "Call `swiper' for small buffers and `counsel-grep' for large ones. +When non-nil, INITIAL-INPUT is the initial search pattern." + (interactive) + (if (or (not buffer-file-name) + (buffer-narrowed-p) + (ignore-errors + (file-remote-p buffer-file-name)) + (jka-compr-get-compression-info buffer-file-name) + (funcall counsel-grep-use-swiper-p)) + (swiper initial-input) + (when (file-writable-p buffer-file-name) + (save-buffer)) + (counsel-grep initial-input))) + +;;;; `counsel-grep-or-swiper-backward' + +;;;###autoload +(defun counsel-grep-or-swiper-backward (&optional initial-input) + "Call `swiper-backward' for small buffers and `counsel-grep-backward' for +large ones. When non-nil, INITIAL-INPUT is the initial search pattern." + (interactive) + (let ((ivy-index-functions-alist + '((swiper . ivy-recompute-index-swiper-backward) + (counsel-grep . ivy-recompute-index-swiper-async-backward)))) + (counsel-grep-or-swiper initial-input))) + +;;;; `counsel-recoll' + +(defun counsel-recoll-function (str) + "Run recoll for STR." + (or + (ivy-more-chars) + (progn + (counsel--async-command + (format "recoll -t -b %s" + (shell-quote-argument str))) + nil))) + +;; This command uses the recollq command line tool that comes together +;; with the recoll (the document indexing database) source: +;; https://www.lesbonscomptes.com/recoll/download.html +;; You need to build it yourself (together with recoll): +;; cd ./query && make && sudo cp recollq /usr/local/bin +;; You can try the GUI version of recoll with: +;; sudo apt-get install recoll +;; Unfortunately, that does not install recollq. +;;;###autoload +(defun counsel-recoll (&optional initial-input) + "Search for a string in the recoll database. +You'll be given a list of files that match. +Selecting a file will launch `swiper' for that file. +INITIAL-INPUT can be given as the initial minibuffer input." + (interactive) + (counsel-require-program "recoll") + (ivy-read "recoll: " 'counsel-recoll-function + :initial-input initial-input + :dynamic-collection t + :history 'counsel-git-grep-history + :action (lambda (x) + (when (string-match "file://\\(.*\\)\\'" x) + (let ((file-name (match-string 1 x))) + (find-file file-name) + (unless (string-match "pdf$" x) + (swiper ivy-text))))) + :caller 'counsel-recoll)) + +(ivy-configure 'counsel-recoll + :unwind-fn #'counsel-delete-process) + +;;; Org +;;;; `counsel-org-tag' + +(defvar counsel-org-tags nil + "Store the current list of tags.") + +(defvar org-outline-regexp) +(defvar org-indent-mode) +(defvar org-indent-indentation-per-level) +(defvar org-tags-column) +(declare-function org-get-tags "org") +(declare-function org-move-to-column "org-compat") + +(defun counsel--org-make-tag-string () + (if (fboundp 'org-make-tag-string) + ;; >= Org 9.2 + (org-make-tag-string (counsel--org-get-tags)) + (with-no-warnings + (org-get-tags-string)))) + +(defun counsel-org-change-tags (tags) + "Change tags of current org headline to TAGS." + (let ((current (counsel--org-make-tag-string)) + (col (current-column)) + level) + ;; Insert new tags at the correct column + (beginning-of-line 1) + (setq level (or (and (looking-at org-outline-regexp) + (- (match-end 0) (point) 1)) + 1)) + (cond + ((and (equal current "") (equal tags ""))) + ((re-search-forward + (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$") + (line-end-position) t) + (if (equal tags "") + (delete-region + (match-beginning 0) + (match-end 0)) + (goto-char (match-beginning 0)) + (let* ((c0 (current-column)) + ;; compute offset for the case of org-indent-mode active + (di (if (bound-and-true-p org-indent-mode) + (* (1- org-indent-indentation-per-level) (1- level)) + 0)) + (p0 (if (equal (char-before) ?*) (1+ (point)) (point))) + (tc (+ org-tags-column (if (> org-tags-column 0) (- di) di))) + (c1 (max (1+ c0) (if (> tc 0) tc (- (- tc) (string-width tags))))) + (rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags))) + (replace-match rpl t t) + (and c0 indent-tabs-mode (tabify p0 (point))) + tags))) + (t (error "Tags alignment failed"))) + (org-move-to-column col))) + +(defun counsel-org--set-tags () + "Set tags of current org headline to `counsel-org-tags'." + (counsel-org-change-tags + (if counsel-org-tags + (format ":%s:" + (mapconcat #'identity counsel-org-tags ":")) + ""))) + +(defvar org-agenda-bulk-marked-entries) + +;; Moved from `org' to `org-macs' in Emacs 27. +(declare-function org-get-at-bol "org-macs") +(declare-function org-trim "org-macs") + +(declare-function org-agenda-error "org-agenda") + +(defun counsel-org-tag-action (x) + "Add tag X to `counsel-org-tags'. +If X is already part of the list, remove it instead. Quit the selection if +X is selected by either `ivy-done', `ivy-alt-done' or `ivy-immediate-done', +otherwise continue prompting for tags." + (if (member x counsel-org-tags) + (progn + (setq counsel-org-tags (delete x counsel-org-tags))) + (unless (equal x "") + (setq counsel-org-tags (append counsel-org-tags (list x))) + (unless (member x ivy--all-candidates) + (setq ivy--all-candidates (append ivy--all-candidates (list x)))))) + (let ((prompt (counsel-org-tag-prompt))) + (setf (ivy-state-prompt ivy-last) prompt) + (setq ivy--prompt (concat "%-4d " prompt))) + (cond ((memq this-command '(ivy-done + ivy-alt-done + ivy-immediate-done)) + (if (eq major-mode 'org-agenda-mode) + (if (null org-agenda-bulk-marked-entries) + (let ((hdmarker (or (org-get-at-bol 'org-hd-marker) + (org-agenda-error)))) + (with-current-buffer (marker-buffer hdmarker) + (goto-char hdmarker) + (counsel-org--set-tags))) + (let ((add-tags (copy-sequence counsel-org-tags))) + (dolist (m org-agenda-bulk-marked-entries) + (with-current-buffer (marker-buffer m) + (save-excursion + (goto-char m) + (setq counsel-org-tags + (delete-dups + (append (counsel--org-get-tags) add-tags))) + (counsel-org--set-tags)))))) + (counsel-org--set-tags) + (unless (member x counsel-org-tags) + (message "Tag %S has been removed." x)))) + ((eq this-command 'ivy-call) + (with-selected-window (active-minibuffer-window) + (delete-minibuffer-contents))))) + +(defun counsel-org-tag-prompt () + "Return prompt for `counsel-org-tag'." + (format "Tags (%s): " + (mapconcat #'identity counsel-org-tags ", "))) + +(defvar org-setting-tags) +(defvar org-last-tags-completion-table) +(defvar org-tag-persistent-alist) +(defvar org-tag-alist) +(defvar org-complete-tags-always-offer-all-agenda-tags) + +(declare-function org-at-heading-p "org") +(declare-function org-back-to-heading "org") +(declare-function org-get-buffer-tags "org") +(declare-function org-global-tags-completion-table "org") +(declare-function org-agenda-files "org") +(declare-function org-agenda-set-tags "org-agenda") +(declare-function org-tags-completion-function "org") + +;;;###autoload +(defun counsel--org-get-tags () + (delete "" (condition-case nil + (org-get-tags nil t) + (error (org-get-tags))))) + +;;;###autoload +(defun counsel-org-tag () + "Add or remove tags in `org-mode'." + (interactive) + (save-excursion + (if (eq major-mode 'org-agenda-mode) + (if org-agenda-bulk-marked-entries + (setq counsel-org-tags nil) + (let ((hdmarker (or (org-get-at-bol 'org-hd-marker) + (org-agenda-error)))) + (with-current-buffer (marker-buffer hdmarker) + (goto-char hdmarker) + (setq counsel-org-tags (counsel--org-get-tags))))) + (unless (org-at-heading-p) + (org-back-to-heading t)) + (setq counsel-org-tags (counsel--org-get-tags))) + (let ((org-last-tags-completion-table + (append (and (or org-complete-tags-always-offer-all-agenda-tags + (eq major-mode 'org-agenda-mode)) + (org-global-tags-completion-table + (org-agenda-files))) + (unless (boundp 'org-current-tag-alist) + org-tag-persistent-alist) + (or (if (boundp 'org-current-tag-alist) + org-current-tag-alist + org-tag-alist) + (org-get-buffer-tags))))) + (ivy-read (counsel-org-tag-prompt) + (lambda (str _pred _action) + (delete-dups + (all-completions str #'org-tags-completion-function))) + :history 'org-tags-history + :action #'counsel-org-tag-action + :caller 'counsel-org-tag)))) + +(defvar org-version) + +;;;###autoload +(defun counsel-org-tag-agenda () + "Set tags for the current agenda item." + (interactive) + (cl-letf (((symbol-function (if (version< org-version "9.2") + 'org-set-tags + 'org-set-tags-command)) + #'counsel-org-tag)) + (org-agenda-set-tags))) + +(defcustom counsel-org-headline-display-tags nil + "If non-nil, display tags in matched `org-mode' headlines." + :type 'boolean) + +(defcustom counsel-org-headline-display-todo nil + "If non-nil, display todo keywords in matched `org-mode' headlines." + :type 'boolean) + +(defcustom counsel-org-headline-display-priority nil + "If non-nil, display priorities in matched `org-mode' headlines." + :type 'boolean) + +(defcustom counsel-org-headline-display-comment nil + "If non-nil, display COMMENT string in matched `org-mode' headlines." + :type 'boolean) + +(defcustom counsel-org-headline-display-statistics nil + "If non-nil, display statistics cookie in matched `org-mode' headlines." + :type 'boolean) + +(declare-function org-get-heading "org") +(declare-function org-goto-marker-or-bmk "org") +(declare-function outline-next-heading "outline") + +;;;###autoload +(defalias 'counsel-org-goto #'counsel-outline) + +(defcustom counsel-org-goto-all-outline-path-prefix nil + "Prefix for outline candidates in `counsel-org-goto-all'." + :type '(choice + (const :tag "None" nil) + (const :tag "File name" file-name) + (const :tag "File name (nondirectory part)" file-name-nondirectory) + (const :tag "Buffer name" buffer-name))) + +(defun counsel-org-goto-all--outline-path-prefix () + (cl-case counsel-org-goto-all-outline-path-prefix + (file-name buffer-file-name) + (file-name-nondirectory (file-name-nondirectory buffer-file-name)) + (buffer-name (buffer-name)))) + +(defvar counsel-outline-settings + '((emacs-lisp-mode + :outline-regexp ";;[;*]+[\s\t]+" + :outline-level counsel-outline-level-emacs-lisp) + (org-mode + :outline-title counsel-outline-title-org + :action counsel-org-goto-action + :history counsel-org-goto-history + :caller counsel-org-goto) + ;; markdown-mode package + (markdown-mode + :outline-title counsel-outline-title-markdown) + ;; Built-in mode or AUCTeX package + (latex-mode + :outline-title counsel-outline-title-latex)) + "Alist mapping major modes to their `counsel-outline' settings. + +Each entry is a pair (MAJOR-MODE . PLIST). `counsel-outline' +checks whether an entry exists for the current buffer's +MAJOR-MODE and, if so, loads the settings specified by PLIST +instead of the default settings. The following settings are +recognized: + +- `:outline-regexp' is a regexp to match the beginning of an + outline heading. It is only checked at the start of a line and + so need not start with \"^\". + Defaults to the value of the variable `outline-regexp'. + +- `:outline-level' is a function of no arguments which computes + the level of an outline heading. It is called with point at + the beginning of `outline-regexp' and with the match data + corresponding to `outline-regexp'. + Defaults to the value of the variable `outline-level'. + +- `:outline-title' is a function of no arguments which returns + the title of an outline heading. It is called with point at + the end of `outline-regexp' and with the match data + corresponding to `outline-regexp'. + Defaults to the function `counsel-outline-title'. + +- `:action' is a function of one argument, the selected outline + heading to jump to. This setting corresponds directly to its + eponymous `ivy-read' keyword, as used by `counsel-outline', so + the type of the function's argument depends on the value + returned by `counsel-outline-candidates'. + Defaults to the function `counsel-outline-action'. + +- `:history' is a history list, usually a symbol representing a + history list variable. It corresponds directly to its + eponymous `ivy-read' keyword, as used by `counsel-outline'. + Defaults to the symbol `counsel-outline-history'. + +- `:caller' is a symbol to uniquely identify the caller to + `ivy-read'. It corresponds directly to its eponymous + `ivy-read' keyword, as used by `counsel-outline'. + Defaults to the symbol `counsel-outline'. + +- `:display-style' overrides the variable + `counsel-outline-display-style'. + +- `:path-separator' overrides the variable + `counsel-outline-path-separator'. + +- `:face-style' overrides the variable + `counsel-outline-face-style'. + +- `:custom-faces' overrides the variable + `counsel-outline-custom-faces'.") + +;;;###autoload +(defun counsel-org-goto-all () + "Go to a different location in any org file." + (interactive) + (let (entries) + (dolist (b (buffer-list)) + (with-current-buffer b + (when (derived-mode-p 'org-mode) + (setq entries + (nconc entries + (counsel-outline-candidates + (cdr (assq 'org-mode counsel-outline-settings)) + (counsel-org-goto-all--outline-path-prefix))))))) + (ivy-read "Goto: " entries + :history 'counsel-org-goto-history + :action #'counsel-org-goto-action + :caller 'counsel-org-goto-all))) + +(defun counsel-org-goto-action (x) + "Go to headline in candidate X." + (org-goto-marker-or-bmk (cdr x))) + +(defun counsel--org-get-heading-args () + "Return list of arguments for `org-get-heading'. +Try to return the right number of arguments for the current Org +version. Argument values are based on the +`counsel-org-headline-display-*' user options." + (nbutlast (mapcar #'not (list counsel-org-headline-display-tags + counsel-org-headline-display-todo + counsel-org-headline-display-priority + counsel-org-headline-display-comment)) + ;; Added in Emacs 26.1. + (if (if (fboundp 'func-arity) + (< (cdr (func-arity #'org-get-heading)) 3) + (version< org-version "9.1.1")) + 2 0))) + +;;;; `counsel-org-file' + +(declare-function org-attach-dir "org-attach") +(declare-function org-attach-file-list "org-attach") +(defvar org-attach-directory) + +(defun counsel-org-files () + "Return list of all files under current Org attachment directories. +Filenames returned are relative to `default-directory'. For each +attachment directory associated with the current buffer, all +contained files are listed, so the return value could conceivably +include attachments of other Org buffers." + (require 'org-attach) + (let (dirs) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward ":\\(?:ATTACH_DIR\\|ID\\):[\t ]+.*$" nil t) + (let ((dir (org-attach-dir))) + (when dir + (push dir dirs))))) + (cl-mapcan + (lambda (dir) + (mapcar (lambda (file) + (file-relative-name (expand-file-name file dir))) + (org-attach-file-list dir))) + (nreverse dirs)))) + +;;;###autoload +(defun counsel-org-file () + "Browse all attachments for current Org file." + (interactive) + (ivy-read "file: " (counsel-org-files) + :action #'counsel-locate-action-dired + :caller 'counsel-org-file)) + +;;;; `counsel-org-entity' + +;;;###autoload +(defun counsel-org-entity () + "Complete Org entities using Ivy." + (interactive) + (require 'org) + (defvar org-entities) + (defvar org-entities-user) + (ivy-read "Entity: " + (cl-loop for element in (append org-entities org-entities-user) + when (consp element) + collect (cons + (format "%20s | %20s | %20s | %s" + (nth 0 element) ; Name. + (nth 1 element) ; LaTeX. + (nth 3 element) ; HTML. + (nth 6 element)) ; UTF-8. + element)) + :require-match t + :action `(1 + ("u" ,(lambda (candidate) + (insert (nth 6 (cdr candidate)))) + "UTF-8") + ("o" ,(lambda (candidate) + (insert "\\" (nth 0 (cdr candidate)))) + "Org entity") + ("l" ,(lambda (candidate) + (insert (nth 1 (cdr candidate)))) + "LaTeX") + ("h" ,(lambda (candidate) + (insert (nth 3 (cdr candidate)))) + "HTML") + ("a" ,(lambda (candidate) + (insert (nth 4 (cdr candidate)))) + "ASCII") + ("L" ,(lambda (candidate) + (insert (nth 5 (cdr candidate)))) + "Latin-1")))) + +;;;; `counsel-org-capture' + +(defvar org-capture-templates) +(defvar org-capture-templates-contexts) +(declare-function org-contextualize-keys "org") +(declare-function org-capture-goto-last-stored "org-capture") +(declare-function org-capture-goto-target "org-capture") +(declare-function org-capture-upgrade-templates "org-capture") + +;;;###autoload +(defun counsel-org-capture () + "Capture something." + (interactive) + (require 'org-capture) + (ivy-read "Capture template: " + ;; We build the list of capture templates as in `org-capture-select-template': + (let (prefixes) + (cl-mapcan + (lambda (x) + (let ((x-keys (car x))) + ;; Remove prefixed keys until we get one that matches the current item. + (while (and prefixes + (let ((p1-keys (caar prefixes))) + (or + (<= (length x-keys) (length p1-keys)) + (not (string-prefix-p p1-keys x-keys))))) + (pop prefixes)) + (if (> (length x) 2) + (let ((desc (mapconcat #'cadr (reverse (cons x prefixes)) " | "))) + (list (format "%-5s %s" x-keys desc))) + (push x prefixes) + nil))) + (or (org-contextualize-keys + (org-capture-upgrade-templates org-capture-templates) + org-capture-templates-contexts) + '(("t" "Task" entry (file+headline "" "Tasks") + "* TODO %?\n %u\n %a"))))) + :require-match t + :action (lambda (x) + (org-capture nil (car (split-string x)))) + :caller 'counsel-org-capture)) + +(ivy-configure 'counsel-org-capture + :initial-input "^") + +(ivy-set-actions + 'counsel-org-capture + `(("t" ,(lambda (x) + (org-capture-goto-target (car (split-string x)))) + "go to target") + ("l" ,(lambda (_x) + (org-capture-goto-last-stored)) + "go to last stored") + ("p" ,(lambda (x) + (org-capture 0 (car (split-string x)))) + "insert template at point") + ("c" ,(lambda (_x) + (customize-variable 'org-capture-templates)) + "customize org-capture-templates"))) + +;;;; `counsel-org-agenda-headlines' + +(defvar org-odd-levels-only) +(declare-function org-map-entries "org") +(declare-function org-heading-components "org") + +(defun counsel-org-agenda-headlines-action-goto (headline) + "Go to the `org-mode' agenda HEADLINE." + (find-file (nth 1 headline)) + (if (fboundp 'org-cycle-set-startup-visibility) + (org-cycle-set-startup-visibility) + ;; Obsolete alias since Org 9.6 / Emacs 29. + (with-no-warnings + (org-set-startup-visibility))) + (goto-char (nth 2 headline)) + (if (fboundp 'org-fold-show-entry) + (org-fold-show-entry) + ;; Obsolete alias since Org 9.6 / Emacs 29. + (with-no-warnings + (org-show-entry)))) + +(ivy-set-actions + 'counsel-org-agenda-headlines + '(("g" counsel-org-agenda-headlines-action-goto "goto headline"))) + +(defvar counsel-org-agenda-headlines-history nil + "History for `counsel-org-agenda-headlines'.") + +(defcustom counsel-outline-display-style 'path + "The style used when displaying matched outline headings. + +If `headline', the title is displayed with leading stars +indicating the outline level. + +If `path', the path hierarchy is displayed. For each entry the +title is shown. Entries are separated with +`counsel-outline-path-separator'. + +If `title' or any other value, only the title of the heading is +displayed. + +For displaying tags and TODO keywords in `org-mode' buffers, see +`counsel-org-headline-display-tags' and +`counsel-org-headline-display-todo', respectively." + :type '(choice + (const :tag "Title only" title) + (const :tag "Headline" headline) + (const :tag "Path" path))) + +(defcustom counsel-outline-path-separator "/" + "String separating path entries in matched outline headings. +This variable has no effect unless +`counsel-outline-display-style' is set to `path'." + :type 'string) + +(declare-function org-get-outline-path "org") + +(defun counsel-org-agenda-headlines--candidates () + "Return a list of completion candidates for `counsel-org-agenda-headlines'." + (org-map-entries + (lambda () + (let* ((components (org-heading-components)) + (level (and (eq counsel-outline-display-style 'headline) + (make-string + (if org-odd-levels-only + (nth 1 components) + (nth 0 components)) + ?*))) + (todo (and counsel-org-headline-display-todo + (nth 2 components))) + (path (and (eq counsel-outline-display-style 'path) + (org-get-outline-path))) + (priority (and counsel-org-headline-display-priority + (nth 3 components))) + (text (nth 4 components)) + (tags (and counsel-org-headline-display-tags + (nth 5 components)))) + (list (string-join + (delq nil (list level + todo + (and priority (format "[#%c]" priority)) + (string-join (append path (list text)) + counsel-outline-path-separator) + tags)) + " ") + buffer-file-name + (point)))) + nil + 'agenda)) + +;;;###autoload +(defun counsel-org-agenda-headlines () + "Choose from headers of `org-mode' files in the agenda." + (interactive) + (require 'org) + (let ((minibuffer-allow-text-properties t)) + (ivy-read "Org headline: " + (counsel-org-agenda-headlines--candidates) + :action #'counsel-org-agenda-headlines-action-goto + :history 'counsel-org-agenda-headlines-history + :caller 'counsel-org-agenda-headlines))) + +;;;; `counsel-org-link' + +;; Moved from `org' to `ol' in Emacs 27. +(declare-function org-insert-link "ol") +(declare-function org-id-get-create "org-id") + +(defun counsel-org-link-action (x) + "Insert a link to X." + (let ((id (save-excursion + (goto-char (cdr x)) + (org-id-get-create)))) + (org-insert-link nil (concat "id:" id) (car x)))) + +;;;###autoload +(defun counsel-org-link () + "Insert a link to an headline with completion." + (interactive) + (ivy-read "Link: " (counsel-outline-candidates + '(:outline-title counsel-outline-title-org )) + :action #'counsel-org-link-action + :history 'counsel-org-link-history + :caller 'counsel-org-link)) + +;;; Misc. Emacs +;;;; `counsel-mark-ring' + +(defface counsel--mark-ring-highlight + '((t :inherit highlight)) + "Face for current `counsel-mark-ring' line." + :group 'ivy-faces) + +(defvar counsel--mark-ring-overlay nil + "Internal overlay to highlight line by candidate of `counsel-mark-ring'.") + +(defun counsel--mark-ring-add-highlight () + "Add highlight to current line." + (setq counsel--mark-ring-overlay + (make-overlay (line-beginning-position) (1+ (line-end-position)))) + (with-ivy-window + (overlay-put counsel--mark-ring-overlay 'face + 'counsel--mark-ring-highlight))) + +(defun counsel--mark-ring-delete-highlight () + "If `counsel-mark-ring' have highlight, delete highlight." + (if counsel--mark-ring-overlay (delete-overlay counsel--mark-ring-overlay))) + +(defvar counsel--mark-ring-calling-point 0 + "Internal variable to remember calling position.") + +(defun counsel--mark-ring-unwind () + "Return back to calling position of `counsel-mark-ring'." + (goto-char counsel--mark-ring-calling-point) + (counsel--mark-ring-delete-highlight)) + +(defun counsel--mark-ring-update-fn () + "Show preview by candidate." + (let ((pos (get-text-property 0 'point (ivy-state-current ivy-last)))) + (counsel--mark-ring-delete-highlight) + (with-ivy-window + (goto-char pos) + (counsel--mark-ring-add-highlight)))) + +;;;###autoload +(defun counsel-mark-ring () + "Browse `mark-ring' interactively. +Obeys `widen-automatically', which see." + (interactive) + (let* ((counsel--mark-ring-calling-point (point)) + (marks (copy-sequence mark-ring)) + (marks (delete-dups marks)) + (marks + ;; mark-marker is empty? + (if (equal (mark-marker) (make-marker)) + marks + (cons (copy-marker (mark-marker)) marks))) + (candidates (counsel-mark--get-candidates marks))) + (if candidates + (counsel-mark--ivy-read "Mark: " candidates 'counsel-mark-ring) + (message "Mark ring is empty")))) + +(defun counsel-mark--get-candidates (marks) + "Convert a list of MARKS into mark candidates. +candidates are simply strings formatted to have the line number of the +associated mark prepended to them and having an extra text property of +point to indicarte where the candidate mark is." + (when marks + (save-excursion + (save-restriction + ;; Widen, both to save `line-number-at-pos' the trouble + ;; and for `buffer-substring' to work. + (widen) + (let* ((width (length (number-to-string (line-number-at-pos (point-max))))) + (fmt (format "%%%dd %%s" width))) + (mapcar (lambda (mark) + (goto-char (marker-position mark)) + (let ((linum (line-number-at-pos)) + (line (buffer-substring + (line-beginning-position) (line-end-position)))) + (propertize (format fmt linum line) 'point (point)))) + marks)))))) + +(defun counsel-mark--ivy-read (prompt candidates caller) + "Call `ivy-read' with sane defaults for traversing marks. +CANDIDATES should be an alist with the `car' of the list being +the completion candidate string and the `cdr' being the point that +mark should take you to. + +This subroutine is intended to be used by both `counsel-mark-ring' and +`counsel-evil-marks'." + (ivy-read prompt candidates + :require-match t + :update-fn #'counsel--mark-ring-update-fn + :action (lambda (cand) + (let ((pos (get-text-property 0 'point cand))) + (when pos + (unless (<= (point-min) pos (point-max)) + (if widen-automatically + (widen) + (error "\ +Position of selected mark outside accessible part of buffer"))) + (goto-char pos)))) + :unwind #'counsel--mark-ring-unwind + :caller caller)) + +(ivy-configure 'counsel-mark-ring + :update-fn #'counsel--mark-ring-update-fn + :unwind-fn #'counsel--mark-ring-unwind + :sort-fn #'ivy-string<) + +;;;; `counsel-evil-marks' + +(defvar counsel-evil-marks-exclude-registers nil + "List of evil registers to not display in `counsel-evil-marks' by default. +Each member of the list should be a character (stored as an integer).") + +(defvar evil-markers-alist) +(declare-function evil-global-marker-p "ext:evil-common") + +(defun counsel-mark--get-evil-candidates (all-markers-p) + "Convert all evil MARKS in the current buffer to mark candidates. +Works like `counsel-mark--get-candidates' but also prepends the +register tied to a mark in the message string." + ;; evil doesn't provide a standalone method to access the list of + ;; marks in the current buffer, as it does with registers. + (let* ((all-markers + (append + (cl-remove-if (lambda (m) + (or (evil-global-marker-p (car m)) + (not (markerp (cdr m))))) + evil-markers-alist) + (cl-remove-if (lambda (m) + (or (not (evil-global-marker-p (car m))) + (not (markerp (cdr m))))) + (default-value 'evil-markers-alist)))) + + (all-markers + ;; with prefix, ignore register exclusion list. + (if all-markers-p + all-markers + (cl-remove-if + (lambda (x) (member (car x) counsel-evil-marks-exclude-registers)) + all-markers))) + ;; separate the markers from the evil registers + ;; for call to `counsel-mark--get-candidates' + (registers (mapcar #'car all-markers)) + (markers (mapcar #'cdr all-markers)) + (candidates (counsel-mark--get-candidates markers))) + (when candidates + (let (register candidate result) + (while (and (setq register (pop registers)) + (setq candidate (pop candidates))) + (let ((point (get-text-property 0 'point candidate)) + (evil-candidate + (format "[%s]: %s" + (propertize (char-to-string register) + 'face 'counsel-evil-register-face) + candidate))) + (push (propertize evil-candidate 'point point) result))) + result)))) + +;;;###autoload +(defun counsel-evil-marks (&optional arg) + "Ivy replacement for `evil-show-marks'. +By default, this function respects `counsel-evil-marks-exclude-registers'. +When ARG is non-nil, display all active evil registers." + (interactive "P") + (if (and (boundp 'evil-markers-alist) + (fboundp 'evil-global-marker-p)) + (let* ((counsel--mark-ring-calling-point (point)) + (candidates (counsel-mark--get-evil-candidates arg))) + (if candidates + (counsel-mark--ivy-read "Evil mark: " candidates 'counsel-evil-marks) + (message "No evil marks are active"))) + (user-error "Required feature `evil' not installed or loaded"))) + +;;;; `counsel-package' + +(defvar package--initialized) +(defvar package-alist) +(defvar package-archive-contents) +(defvar package-archives) +(defvar package-user-dir) +(declare-function package-installed-p "package") +(declare-function package-delete "package") +(declare-function package-desc-extras "package" t t) + +(defvar counsel-package-history nil + "History for `counsel-package'.") + +(defun counsel--package-candidates () + "Return completion alist for `counsel-package'." + (unless package--initialized + (package-initialize t)) + (if (or (not package-archive-contents) + (cl-find-if (lambda (package-archive) + (let ((fname + (format + "%s/archives/%s/archive-contents" + package-user-dir (car package-archive)))) + (or (not (file-exists-p fname)) + (counsel-file-stale-p fname (* 4 60 60))))) + package-archives)) + (package-refresh-contents)) + (sort (mapcar (lambda (entry) + (cons (let ((pkg (car entry))) + (concat (if (package-installed-p pkg) "-" "+") + (symbol-name pkg))) + entry)) + package-archive-contents) + #'counsel--package-sort)) + +;;;###autoload +(defun counsel-package () + "Install or delete packages. + +Packages not currently installed are prefixed with \"+\", and +selecting one of these will try to install it. +Packages currently installed are prefixed with \"-\", and +selecting one of these will try to delete it. + +Additional actions:\\ + + \\[ivy-dispatching-done] d: Describe package + \\[ivy-dispatching-done] h: Visit package's homepage" + (interactive) + (require 'package) + (ivy-read "Packages (install +pkg or delete -pkg): " + (counsel--package-candidates) + :action #'counsel-package-action + :require-match t + :history 'counsel-package-history + :caller 'counsel-package)) + +(ivy-configure 'counsel-package + :initial-input "^+") + +(defun counsel-package-action (package) + "Delete or install PACKAGE." + (setq package (cadr package)) + (if (package-installed-p package) + (package-delete (cadr (assq package package-alist))) + (package-install package))) + +(defun counsel-package-action-describe (package) + "Call `describe-package' on PACKAGE." + (describe-package (cadr package))) + +(defun counsel-package-action-homepage (package) + "Open homepage for PACKAGE in a WWW browser." + (let ((url (cdr (assq :url (package-desc-extras (nth 2 package)))))) + (if url + (browse-url url) + (message "No homepage specified for package `%s'" (nth 1 package))))) + +(defun counsel--package-sort (a b) + "Sort function for `counsel-package' candidates." + (let* ((a (car a)) + (b (car b)) + (a-inst (= (string-to-char a) ?+)) + (b-inst (= (string-to-char b) ?+))) + (or (and a-inst (not b-inst)) + (and (eq a-inst b-inst) (string-lessp a b))))) + +(ivy-set-actions + 'counsel-package + '(("d" counsel-package-action-describe "describe package") + ("h" counsel-package-action-homepage "open package homepage"))) + +;;;; `counsel-tmm' + +(declare-function tmm-get-keymap "tmm" (elt &optional in-x-menu)) + +(defalias 'counsel--menu-keymap + ;; Added in Emacs 28.1. + (if (fboundp 'menu-bar-keymap) + #'menu-bar-keymap + ;; Removed in Emacs 28.1. + (declare-function tmm-get-keybind "tmm" (keyseq) t) + (lambda () (tmm-get-keybind [menu-bar]))) + "Compatibility shim for `menu-bar-keymap'.") + +(defun counsel-tmm-prompt (menu) + "Select and call an item from the MENU keymap." + (defvar tmm-km-list) + (let (out + choice + chosen-string) + (setq tmm-km-list nil) + (map-keymap (lambda (k v) (tmm-get-keymap (cons k v))) menu) + (let ((items (setq tmm-km-list (nreverse tmm-km-list)))) + (setq out (ivy-read "Menu bar: " + ;; From `tmm--completion-table', removed in Emacs 31. + (lambda (str pred action) + (if (eq action 'metadata) + '(metadata (display-sort-function . identity)) + (complete-with-action action items str pred))) + :require-match t))) + (setq choice (cdr (assoc out tmm-km-list))) + (setq chosen-string (car choice)) + (setq choice (cdr choice)) + (cond ((keymapp choice) + (counsel-tmm-prompt choice)) + ((and choice chosen-string) + (setq last-command-event chosen-string) + (call-interactively choice))))) + +;;;###autoload +(defun counsel-tmm () + "Text-mode emulation of looking and choosing from a menu bar." + (interactive) + (require 'tmm) + (defvar tmm-table-undef) + (run-hooks 'menu-bar-update-hook) + (setq tmm-table-undef nil) + (counsel-tmm-prompt (counsel--menu-keymap))) + +;;;; `counsel-yank-pop' + +(defcustom counsel-yank-pop-truncate-radius 2 + "Number of context lines around `counsel-yank-pop' candidates." + :type 'integer) + +(defun counsel--yank-pop-truncate (str) + "Truncate STR for use in `counsel-yank-pop'." + (condition-case nil + (let* ((lines (split-string str "\n" t)) + (n (length lines)) + (re (ivy-re-to-str ivy--old-re)) + (first-match (cl-position-if + (lambda (s) (string-match re s)) + lines)) + (beg (max 0 (- first-match + counsel-yank-pop-truncate-radius))) + (end (min n (+ first-match + counsel-yank-pop-truncate-radius + 1))) + (seq (cl-subseq lines beg end))) + (if (null first-match) + (error "Could not match %s" str) + (when (> beg 0) + (setcar seq (concat "[...] " (car seq)))) + (when (< end n) + (setcar (last seq) + (concat (car (last seq)) " [...]"))) + (mapconcat #'identity seq "\n"))) + (error str))) + +(defcustom counsel-yank-pop-separator "\n" + "Separator for the kill ring strings in `counsel-yank-pop'." + :type '(choice + (const :tag "Plain" "\n") + (const :tag "Dashes" "\n----\n") + string)) + +(defun counsel--yank-pop-format-function (cand-pairs) + "Transform CAND-PAIRS into a string for `counsel-yank-pop'." + (ivy--format-function-generic + (lambda (str) + (mapconcat + (lambda (s) + (ivy--add-face s 'ivy-current-match)) + (split-string + (counsel--yank-pop-truncate str) "\n" t) + "\n")) + (lambda (str) + (counsel--yank-pop-truncate str)) + cand-pairs + (propertize counsel-yank-pop-separator 'face 'ivy-separator))) + +;; Macro to leverage `compiler-macro' of `cl-member' in Emacs >= 24. +(defmacro counsel--idx-of (elt list test) + "Return index of ELT in LIST, comparing with TEST. +Typically faster than `cl-position' using `equal' on large LIST." + ;; No `macroexp-let2*' before Emacs 25. + (macroexp-let2 nil elt elt + (macroexp-let2 nil list list + (macroexp-let2 nil tail `(cl-member ,elt ,list :test ,test) + `(and ,tail (- (length ,list) (length ,tail))))))) + +(defun counsel--yank-pop-position (s) + "Return position of S in `kill-ring' relative to last yank." + (or (counsel--idx-of s kill-ring-yank-pointer #'equal-including-properties) + (counsel--idx-of s kill-ring-yank-pointer #'equal) + (+ (or (counsel--idx-of s kill-ring #'equal-including-properties) + (counsel--idx-of s kill-ring #'equal)) + (- (length kill-ring-yank-pointer) + (length kill-ring))))) + +(defun counsel-string-non-blank-p (s) + "Return non-nil if S includes non-blank characters. +Newlines and carriage returns are considered blank." + (string-match-p "[^\n\r[:blank:]]" s)) + +(defcustom counsel-yank-pop-filter #'counsel-string-non-blank-p + "Unary filter function applied to `counsel-yank-pop' candidates. +All elements of `kill-ring' for which this function returns nil +will be destructively removed from `kill-ring' before completion. +All blank strings are deleted from `kill-ring' by default." + :type '(radio + (function-item counsel-string-non-blank-p) + (function-item identity) ;; Faster than the newer `always'. + (function :tag "Other"))) + +(defun counsel--equal-w-props () + "Return a `hash-table-test' using `equal-including-properties'. +If not available, return nil." + ;; Added in Emacs 28. + (when (fboundp 'sxhash-equal-including-properties) + (let ((name 'counsel--equal-w-props)) + ;; Define the test only once. + (unless (get name 'hash-table-test) + (define-hash-table-test name #'equal-including-properties + #'sxhash-equal-including-properties)) + name))) + +(defun counsel--yank-pop-filter (kills) + "Apply `counsel-yank-pop-filter' to and deduplicate KILLS. +Equality is defined by `equal-including-properties' for some consistency +with `kill-do-not-save-duplicates' (which is otherwise ignored). This +function tries to be faster than `cl-delete-duplicates' when possible." + (let* ((pred counsel-yank-pop-filter) + (len (length kills)) + ;; Same threshold as `delete-dups'. + (test (and (> len 100) (counsel--equal-w-props)))) + (if (not test) ;; Slow fallback. + (cl-delete-duplicates (cl-delete-if-not pred kills) + :test #'equal-including-properties + :from-end t) + ;; The rest is `delete-dups' combined with `delete' in a single pass. + ;; Find first (or no) element that passes through filter. + (while (unless (funcall pred (car kills)) + (cl-decf len) + (setq kills (cdr kills)))) + (let ((ht (make-hash-table :test test :size len)) + (tail kills) + retail) + ;; Mark it and continue with the rest. + (puthash (car tail) t ht) + (while (setq retail (cdr tail)) + (let ((elt (car retail))) + (if (or (gethash elt ht) + (not (funcall pred elt))) + (setcdr tail (cdr retail)) + (puthash elt t ht) + (setq tail retail))))) + kills))) + +(defun counsel--yank-pop-kills () + "Return filtered `kill-ring' for `counsel-yank-pop' completion. +Both `kill-ring' and `kill-ring-yank-pointer' may be +destructively modified to eliminate duplicates under +`equal-including-properties', satisfy `counsel-yank-pop-filter', +and incorporate `interprogram-paste-function'." + ;; Protect against `kill-ring' and result of + ;; `interprogram-paste-function' both being nil + (ignore-errors (current-kill 0)) + ;; Keep things consistent with the rest of Emacs + (prog1 (setq kill-ring (counsel--yank-pop-filter kill-ring)) + (setq kill-ring-yank-pointer + (counsel--yank-pop-filter kill-ring-yank-pointer)))) + +(defcustom counsel-yank-pop-after-point nil + "Whether `counsel-yank-pop' yanks after point. +Nil means `counsel-yank-pop' puts point at the end of the yanked +text and mark at its beginning, as per the default \\[yank]. +Non-nil means `counsel-yank-pop' swaps the resulting point and +mark, as per \\[universal-argument] \\[yank]." + :type 'boolean) + +(defun counsel-yank-pop-action (s) + "Like `yank-pop', but insert the kill corresponding to S. +Signal a `buffer-read-only' error if called from a read-only +buffer position." + (when (and (eq major-mode 'vterm-mode) + (fboundp 'vterm-insert)) + (let ((inhibit-read-only t)) + (vterm-insert s))) + (barf-if-buffer-read-only) + (setq yank-window-start (window-start)) + (unless (eq last-command 'yank) + ;; Avoid unexpected deletions with `yank-handler' properties. + (setq yank-undo-function nil)) + (condition-case nil + (let (;; Deceive `yank-pop'. + (last-command 'yank) + ;; Avoid unexpected additions to `kill-ring'. + interprogram-paste-function) + (yank-pop (counsel--yank-pop-position s))) + (error + ;; Support strings not present in the kill ring. + (insert s))) + (when (funcall (if counsel-yank-pop-after-point #'> #'<) + (point) (mark t)) + (exchange-point-and-mark t))) + +(defun counsel-yank-pop-action-remove (s) + "Remove all occurrences of S from the kill ring." + (setq kill-ring + (cl-delete s kill-ring :test #'equal-including-properties)) + (setq kill-ring-yank-pointer + (cl-delete s kill-ring-yank-pointer :test #'equal-including-properties)) + ;; Update collection and preselect for next `ivy-call' + (setf (ivy-state-collection ivy-last) kill-ring) + (setf (ivy-state-preselect ivy-last) + (nth (min ivy--index (1- (length kill-ring))) + kill-ring)) + (ivy--reset-state ivy-last)) + +(defun counsel-yank-pop-action-rotate (s) + "Rotate the yanking point to S in the kill ring. +See `current-kill' for how this interacts with the window system +selection." + (let ((i (counsel--yank-pop-position s))) + ;; Avoid unexpected additions to `kill-ring' + (let (interprogram-paste-function) + (setf (ivy-state-preselect ivy-last) (current-kill i))) + ;; Manually change window system selection because `current-kill' won't + (when (and (zerop i) + yank-pop-change-selection + interprogram-cut-function) + (funcall interprogram-cut-function (car kill-ring-yank-pointer)))) + (ivy--reset-state ivy-last)) + +(defcustom counsel-yank-pop-preselect-last nil + "Whether `counsel-yank-pop' preselects the last kill by default. + +The command `counsel-yank-pop' always preselects the same kill +that `yank-pop' would have inserted, given the same prefix +argument. + +When `counsel-yank-pop-preselect-last' is nil (the default), the +prefix argument of `counsel-yank-pop' defaults to 1 (as per +`yank-pop'), which causes the next-to-last kill to be +preselected. Otherwise, the prefix argument defaults to 0, which +results in the most recent kill being preselected." + :type 'boolean) + +;;;###autoload +(defun counsel-yank-pop (&optional arg) + "Ivy replacement for `yank-pop'. +With a plain prefix argument (\\[universal-argument]), +temporarily toggle the value of `counsel-yank-pop-after-point'. +Any other value of ARG has the same meaning as in `yank-pop', but +`counsel-yank-pop-preselect-last' determines its default value. +See also `counsel-yank-pop-filter' for how to filter candidates. + +Note: Duplicate elements of `kill-ring' are always deleted." + ;; Do not specify `*' to allow browsing `kill-ring' in read-only buffers + (interactive "P") + (let ((kills (or (counsel--yank-pop-kills) + (error "Kill ring is empty or blank"))) + (preselect (let (interprogram-paste-function) + (current-kill (cond ((nlistp arg) + (prefix-numeric-value arg)) + (counsel-yank-pop-preselect-last 0) + (t 1)) + t))) + (counsel-yank-pop-after-point + (xor (consp arg) counsel-yank-pop-after-point))) + (unless (eq last-command 'yank) + (push-mark)) + (ivy-read "kill-ring: " kills + :require-match t + :preselect preselect + :action #'counsel-yank-pop-action + :caller 'counsel-yank-pop))) + +(function-put #'counsel-yank-pop 'delete-selection 'yank) + +(ivy-configure 'counsel-yank-pop + :height 5 + :format-fn #'counsel--yank-pop-format-function) + +(ivy-set-actions + 'counsel-yank-pop + '(("d" counsel-yank-pop-action-remove "delete") + ("r" counsel-yank-pop-action-rotate "rotate"))) + +;;;; `counsel-register' + +(defvar counsel-register-actions + '(("\\`buffer" . jump-to-register) + ("\\`text" . insert-register) + ("\\`rectangle" . insert-register) + ("\\`window" . jump-to-register) + ("\\`frame" . jump-to-register) + ("\\`[-+]?[0-9]+\\(?:\\.[0-9]\\)?\\'" . insert-register) + ("\\`\\(?:the \\)?file " . jump-to-register) + ("\\`keyboard" . jump-to-register) + ("\\`file-query" . jump-to-register)) + "Alist of (REGEXP . FUNCTION) pairs for `counsel-register'. +Selecting a register whose description matches REGEXP specifies +FUNCTION as the action to take on the register.") + +(defvar counsel-register-history nil + "History for `counsel-register'.") + +(defun counsel-register-action (register) + "Default action for `counsel-register'. + +Call a function on REGISTER. The function is determined by +matching the register's value description against a regexp in +`counsel-register-actions'." + (let* ((val (get-text-property 0 'register register)) + (desc (register-describe-oneline val)) + (action (cdr (cl-assoc-if (lambda (re) (string-match-p re desc)) + counsel-register-actions)))) + (if action + (funcall action val) + (error "No action was found for register %s" + (single-key-description val))))) + +;;;###autoload +(defun counsel-register () + "Interactively choose a register." + (interactive) + (ivy-read "Register: " + (cl-mapcan + (lambda (reg) + (let ((s (funcall register-preview-function reg))) + (setq s (substring s 0 (string-match-p "[ \t\n\r]+\\'" s))) + (unless (string= s "") + (put-text-property 0 1 'register (car reg) s) + (list s)))) + register-alist) + :require-match t + :history 'counsel-register-history + :action #'counsel-register-action + :caller 'counsel-register)) + +(ivy-configure 'counsel-register + :sort-fn #'ivy-string<) + +;;;; `counsel-evil-registers' + +(defface counsel-evil-register-face + '((t :inherit counsel-outline-1)) + "Face for highlighting `evil' registers in ivy." + :group 'ivy-faces) + +;;;###autoload +(defun counsel-evil-registers () + "Ivy replacement for `evil-show-registers'." + (interactive) + (if (fboundp 'evil-register-list) + (ivy-read "evil-registers: " + (cl-loop for (key . val) in (evil-register-list) + collect (format "[%s]: %s" + (propertize (char-to-string key) + 'face 'counsel-evil-register-face) + (if (stringp val) val ""))) + :require-match t + :action #'counsel-evil-registers-action + :caller 'counsel-evil-registers) + (user-error "Required feature `evil' not installed"))) + +(ivy-configure 'counsel-evil-registers + :height 5 + :format-fn #'counsel--yank-pop-format-function) + +(defun counsel-evil-registers-action (s) + "Paste contents of S, trimming the register part. + +S will be of the form \"[register]: content\"." + (with-ivy-window + (insert + (replace-regexp-in-string "\\`\\[.*?]: " "" s t t)))) + +;;;; `counsel-imenu' + +(declare-function imenu--subalist-p "imenu") +(declare-function imenu--make-index-alist "imenu") + +(defun counsel--imenu-candidates () + (require 'imenu) + (defvar imenu-auto-rescan) + (defvar imenu-auto-rescan-maxout) + (let* ((imenu-auto-rescan t) + (imenu-auto-rescan-maxout (if current-prefix-arg + (buffer-size) + imenu-auto-rescan-maxout)) + (items (imenu--make-index-alist t)) + (items (delete (assoc "*Rescan*" items) items)) + (items (cond ((eq major-mode 'emacs-lisp-mode) + (counsel-imenu-categorize-functions items)) + ((and (derived-mode-p 'python-mode) + (fboundp 'python-imenu-create-flat-index)) + (python-imenu-create-flat-index)) + (t + items)))) + (counsel-imenu-get-candidates-from items))) + +(defun counsel-imenu-get-candidates-from (alist &optional prefix) + "Create a list of (key . value) from ALIST. +PREFIX is used to create the key." + (cl-mapcan + (lambda (elm) + (if (imenu--subalist-p elm) + (counsel-imenu-get-candidates-from + (cl-loop for (e . v) in (cdr elm) collect + (cons e (if (integerp v) (copy-marker v) v))) + ;; pass the prefix to next recursive call + (concat prefix (if prefix ".") (car elm))) + (let ((key (concat + (when prefix + (concat + (propertize prefix 'face 'ivy-grep-info) + ": ")) + (car elm)))) + (list (cons key + (cons key (if (overlayp (cdr elm)) + (overlay-start (cdr elm)) + (cdr elm)))))))) + alist)) + +(defvar counsel-imenu-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-l") #'ivy-call-and-recenter) + map)) + +(defun counsel-imenu-categorize-functions (items) + "Categorize all the functions of imenu." + (let ((fns (cl-remove-if #'listp items :key #'cdr))) + (if fns + (append (cl-remove-if #'nlistp items :key #'cdr) + `(("Functions" ,@fns))) + items))) + +(defun counsel-imenu-action (x) + (imenu (cdr x))) + +(defvar counsel-imenu-history nil + "History for `counsel-imenu'.") + +;;;###autoload +(defun counsel-imenu () + "Jump to a buffer position indexed by imenu." + (interactive) + (ivy-read "imenu items: " (counsel--imenu-candidates) + :preselect (thing-at-point 'symbol) + :require-match t + :action #'counsel-imenu-action + :keymap counsel-imenu-map + :history 'counsel-imenu-history + :caller 'counsel-imenu)) + +;;;; `counsel-list-processes' + +(defun counsel-list-processes-action-delete (x) + "Delete process X." + (delete-process x) + (setf (ivy-state-collection ivy-last) + (setq ivy--all-candidates + (delete x ivy--all-candidates)))) + +(defun counsel-list-processes-action-switch (x) + "Switch to buffer of process X." + (let* ((proc (get-process x)) + (buf (and proc (process-buffer proc)))) + (if buf + (switch-to-buffer buf) + (message "Process %s doesn't have a buffer" x)))) + +;;;###autoload +(defun counsel-list-processes () + "Offer completion for `process-list'. +The default action deletes the selected process. +An extra action allows to switch to the process buffer." + (interactive) + (with-temp-buffer + (list-processes--refresh)) + (ivy-read "Process: " (mapcar #'process-name (process-list)) + :require-match t + :action + '(1 + ("o" counsel-list-processes-action-delete "kill") + ("s" counsel-list-processes-action-switch "switch")) + :caller 'counsel-list-processes)) + +;;;; `counsel-ace-link' + +(defun counsel-ace-link () + "Use Ivy completion for `ace-link'." + (interactive) + (let (collection action) + (cond ((eq major-mode 'Info-mode) + (setq collection 'ace-link--info-collect) + (setq action 'ace-link--info-action)) + ((eq major-mode 'help-mode) + (setq collection 'ace-link--help-collect) + (setq action 'ace-link--help-action)) + ((eq major-mode 'woman-mode) + (setq collection 'ace-link--woman-collect) + (setq action 'ace-link--woman-action)) + ((eq major-mode 'eww-mode) + (setq collection 'ace-link--eww-collect) + (setq action 'ace-link--eww-action)) + ((eq major-mode 'compilation-mode) + (setq collection 'ace-link--eww-collect) + (setq action 'ace-link--compilation-action)) + ((eq major-mode 'org-mode) + (setq collection 'ace-link--org-collect) + (setq action 'ace-link--org-action))) + (if (null collection) + (error "%S is not supported" major-mode) + (ivy-read "Ace-Link: " (funcall collection) + :action (lambda (x) (funcall action (cdr x))) + :require-match t + :caller 'counsel-ace-link)))) + +;;;; `counsel-minibuffer-history' + +;;;###autoload +(defun counsel-minibuffer-history () + "Browse minibuffer history." + (interactive) + (let ((enable-recursive-minibuffers t)) + (ivy-read "History: " (ivy-history-contents minibuffer-history-variable) + :keymap ivy-reverse-i-search-map + :action (lambda (x) + (delete-minibuffer-contents) + (insert (substring-no-properties (car x)))) + :caller 'counsel-minibuffer-history))) + +;;;; `counsel-esh-history' + +(defvar comint-input-ring-index) +(defvar eshell-history-index) +(defvar slime-repl-input-history-position) + +(defvar counsel-esh--index-last nil + "Index corresponding to last selection with `counsel-esh-history'.") + +(defvar counsel-shell-history--index-last nil + "Index corresponding to last selection with `counsel-shell-history'.") + +(defun counsel--browse-history-action (pair) + (let ((snd (cdr pair))) + (cl-case (ivy-state-caller ivy-last) + (counsel-esh-history + (setq eshell-history-index snd + counsel-esh--index-last snd)) + (counsel-shell-history + (setq comint-input-ring-index snd + counsel-shell-history--index-last snd)) + ;; Leave this as a no-op. If someone decides to patch + ;; `slime-repl-previous-input' or one of its utility functions, + ;; or to add history-replay to Slime, then this section can be + ;; updated to add the relevant support for those commands. + (counsel-slime-repl-history + nil)) + (ivy-completion-in-region-action (car pair)))) + +(cl-defun counsel--browse-history (ring &key caller) + "Use Ivy to navigate through RING." + (let* ((proc (get-buffer-process (current-buffer))) + (end (point)) + (beg (if proc + (min (process-mark proc) end) + end)) + (input (when (< beg end) + (concat "^" (buffer-substring beg end))))) + (setq ivy-completion-beg beg) + (setq ivy-completion-end end) + (ivy-read "History: " (ivy-history-contents ring) + :keymap ivy-reverse-i-search-map + :initial-input input + :action #'counsel--browse-history-action + :caller caller))) + +(defvar eshell-history-ring) +(defvar eshell-matching-input-from-input-string) + +;;;###autoload +(defun counsel-esh-history () + "Browse Eshell history." + (interactive) + (require 'em-hist) + (counsel--browse-history eshell-history-ring + :caller #'counsel-esh-history)) + +(advice-add 'eshell-previous-matching-input + :before #'counsel--set-eshell-history-index) +(defun counsel--set-eshell-history-index (&rest _) + "Reassign `eshell-history-index'." + (when (and (memq last-command '(ivy-alt-done ivy-done)) + (equal (ivy-state-caller ivy-last) 'counsel-esh-history)) + (setq eshell-history-index counsel-esh--index-last))) + +(defvar comint-input-ring) +(defvar comint-matching-input-from-input-string) + +;;;###autoload +(defun counsel-shell-history () + "Browse shell history." + (interactive) + (require 'comint) + (counsel--browse-history comint-input-ring + :caller #'counsel-shell-history)) + +(advice-add 'comint-previous-matching-input + :before #'counsel--set-comint-history-index) +(defun counsel--set-comint-history-index (&rest _) + "Reassign `comint-input-ring-index'." + (when (and (memq last-command '(ivy-alt-done ivy-done)) + (equal (ivy-state-caller ivy-last) 'counsel-shell-history)) + (setq comint-input-ring-index counsel-shell-history--index-last))) + +(defvar slime-repl-input-history) + +;;;###autoload +(defun counsel-slime-repl-history () + "Browse Slime REPL history." + (interactive) + (require 'slime-repl) + (counsel--browse-history slime-repl-input-history + :caller #'counsel-slime-repl-history)) + +;; TODO: add advice for slime-repl-input-previous/next to properly +;; reassign the ring index and match string. This requires a case for +;; `counsel-slime-repl-history' within +;; `counsel--browse-history-action'. + +;;;; `counsel-hydra-heads' + +(defvar hydra-curr-body-fn) +(declare-function hydra-keyboard-quit "ext:hydra") + +;;;###autoload +(defun counsel-hydra-heads () + "Call a head of the current/last hydra." + (interactive) + (let* ((base (substring + (prin1-to-string hydra-curr-body-fn) + 0 -4)) + (heads (symbol-value (intern (concat base "heads")))) + (keymap (symbol-value (intern (concat base "keymap")))) + (head-names + (mapcar (lambda (x) + (cons + (if (nth 2 x) + (format "[%s] %S (%s)" (nth 0 x) (nth 1 x) (nth 2 x)) + (format "[%s] %S" (nth 0 x) (nth 1 x))) + (lookup-key keymap (kbd (nth 0 x))))) + heads))) + (ivy-read "head: " head-names + :action (lambda (x) (call-interactively (cdr x)))) + (hydra-keyboard-quit))) + +;;;; `counsel-semantic' + +(declare-function semantic-tag-start "semantic/tag") +(declare-function semantic-tag-class "semantic/tag") +(declare-function semantic-tag-name "semantic/tag") +(declare-function semantic-tag-put-attribute "semantic/tag") +(declare-function semantic-tag-get-attribute "semantic/tag") +(declare-function semantic-fetch-tags "semantic") +(declare-function semantic-format-tag-summarize "semantic/format") +(declare-function semantic-active-p "semantic/fw") + +(defun counsel-semantic-action (x) + "Got to semantic TAG." + (goto-char (semantic-tag-start (cdr x)))) + +(defvar counsel-semantic-history nil + "History for `counsel-semantic'.") + +(defun counsel-semantic-format-tag (tag) + "Return a pretty string representation of TAG." + (let ((depth (or (semantic-tag-get-attribute tag :depth) 0)) + (parent (semantic-tag-get-attribute tag :parent))) + (concat (make-string (* depth 2) ?\ ) + (if parent + (concat "(" parent ") ") + "") + (semantic-format-tag-summarize tag nil t)))) + +(defun counsel-flatten-forest (func treep forest) + "Use FUNC and TREEP to flatten FOREST. +FUNC is applied to each node. +TREEP is used to expand internal nodes." + (cl-labels ((reducer (forest out depth) + (dolist (tree forest) + (let ((this (cons (funcall func tree depth) out)) + (leafs (funcall treep tree))) + (setq out + (if leafs + (reducer leafs this (1+ depth)) + this)))) + out)) + (nreverse (reducer forest nil 0)))) + +(defun counsel-semantic-tags () + "Fetch semantic tags." + (counsel-flatten-forest + (lambda (tree depth) + (semantic-tag-put-attribute tree :depth depth)) + (lambda (tag) + (when (eq (semantic-tag-class tag) 'type) + (let ((name (semantic-tag-name tag))) + (mapcar + (lambda (x) (semantic-tag-put-attribute x :parent name)) + (semantic-tag-get-attribute tag :members))))) + (semantic-fetch-tags))) + +;;;###autoload +(defun counsel-semantic () + "Jump to a semantic tag in the current buffer." + (interactive) + (let ((tags (mapcar + (lambda (x) + (cons + (counsel-semantic-format-tag x) + x)) + (counsel-semantic-tags)))) + (ivy-read "tag: " tags + :action #'counsel-semantic-action + :history 'counsel-semantic-history + :caller 'counsel-semantic))) + +;;;###autoload +(defun counsel-semantic-or-imenu () + (interactive) + (require 'semantic/fw) + (if (semantic-active-p) + (counsel-semantic) + (counsel-imenu))) + +;;;; `counsel-outline' + +(defcustom counsel-outline-face-style nil + "Determines how to style outline headings during completion. + +If `org', the faces `counsel-outline-1' through +`counsel-outline-8' are applied in a similar way to Org. +Note that no cycling is performed, so headings on levels 9 and +higher are not styled. + +If `verbatim', the faces used in the buffer are applied. For +simple headlines in `org-mode' buffers, this is usually the same +as the `org' setting, except that it depends on how much of the +buffer has been completely fontified. If your buffer exceeds a +certain size, headlines are styled lazily depending on which +parts of the tree are visible. Headlines which are not yet +styled in the buffer will appear unstyled in the minibuffer as +well. If your headlines contain parts which are fontified +differently than the headline itself (e.g. TODO keywords, tags, +links) and you want these parts to be styled properly, verbatim +is the way to go; otherwise you are probably better off using the +`org' setting instead. + +If `custom', the faces defined in `counsel-outline-custom-faces' +are applied. Note that no cycling is performed, so if there is +no face defined for a certain level, headlines on that level will +not be styled. + +If `nil', all headlines are highlighted using +`counsel-outline-default'. + +For displaying tags and TODO keywords in `org-mode' buffers, see +`counsel-org-headline-display-tags' and +`counsel-org-headline-display-todo', respectively." + :type '(choice + (const :tag "Same as org-mode" org) + (const :tag "Verbatim" verbatim) + (const :tag "Custom" custom) + (const :tag "No style" nil))) + +(defcustom counsel-outline-custom-faces nil + "List of faces for custom display of outline headings. + +Headlines on level N are fontified with the Nth entry of this +list, starting with N = 1. Headline levels with no corresponding +entry in this list will not be styled. + +This variable has no effect unless `counsel-outline-face-style' +is set to `custom'." + :type '(repeat face)) + +(defun counsel-outline-title () + "Return title of current outline heading. +Intended as a value for the `:outline-title' setting in +`counsel-outline-settings', which see." + (buffer-substring (point) (line-end-position))) + +(defun counsel-outline-title-org () + "Return title of current outline heading. +Like `counsel-outline-title' (which see), but for `org-mode' +buffers." + (let ((statistics-re "\\[[0-9]*\\(?:%\\|/[0-9]*\\)]") + (heading (apply #'org-get-heading (counsel--org-get-heading-args)))) + (cond (counsel-org-headline-display-statistics + heading) + (heading + (org-trim (replace-regexp-in-string + statistics-re " " heading t t)))))) + +(defun counsel-outline-title-markdown () + "Return title of current outline heading. +Like `counsel-outline-title' (which see), but for +`markdown-mode' (from the eponymous package) buffers." + ;; `outline-regexp' is set by `markdown-mode' to match both setext + ;; (underline) and atx (hash) headings (see + ;; `markdown-regex-header'). + (or (match-string 1) ; setext heading title + (match-string 5))) ; atx heading title + +(defun counsel-outline-title-latex () + "Return title of current outline heading. +Like `counsel-outline-title' (which see), but for `latex-mode' +buffers." + ;; `outline-regexp' is set by `latex-mode' (see variable + ;; `latex-section-alist' for the built-in mode or function + ;; `LaTeX-outline-regexp' for the AUCTeX package) to match section + ;; macros, in which case we get the section name, as well as + ;; `\appendix', `\documentclass', `\begin{document}', and + ;; `\end{document}', in which case we simply return that. + (if (and (assoc (match-string 1) ; Macro name + (or (bound-and-true-p LaTeX-section-list) ; AUCTeX + (bound-and-true-p latex-section-alist))) ; Built-in + (progn + ;; Point is at end of macro name, skip stars and optional args + (skip-chars-forward "*") + (while (looking-at-p "\\[") + (forward-list)) + ;; First mandatory arg should be section title + (looking-at-p "{"))) + (buffer-substring (1+ (point)) (1- (progn (forward-list) (point)))) + (buffer-substring (line-beginning-position) (point)))) + +(defun counsel-outline-level-emacs-lisp () + "Return level of current outline heading. +Like `lisp-outline-level', but adapted for the `:outline-level' +setting in `counsel-outline-settings', which see." + (if (looking-at ";;\\([;*]+\\)") + (- (match-end 1) (match-beginning 1)) + (funcall outline-level))) + +(defvar counsel-outline--preselect 0 + "Index of the preselected candidate in `counsel-outline'.") + +(defun counsel-outline-candidates (&optional settings prefix) + "Return an alist of outline heading completion candidates. +Each element is a pair (HEADING . MARKER), where the string +HEADING is located at the position of MARKER. SETTINGS is a +plist entry from `counsel-outline-settings', which see. +PREFIX is a string prepended to all candidates." + (let* ((bol-regex (concat "^\\(?:" + (or (plist-get settings :outline-regexp) + outline-regexp) + "\\)")) + (outline-title-fn (or (plist-get settings :outline-title) + #'counsel-outline-title)) + (outline-level-fn (or (plist-get settings :outline-level) + outline-level)) + (display-style (or (plist-get settings :display-style) + counsel-outline-display-style)) + (path-separator (or (plist-get settings :path-separator) + counsel-outline-path-separator)) + (face-style (or (plist-get settings :face-style) + counsel-outline-face-style)) + (custom-faces (or (plist-get settings :custom-faces) + counsel-outline-custom-faces)) + (stack-level 0) + (orig-point (point)) + (stack (and prefix (list (counsel-outline--add-face + prefix 0 face-style custom-faces)))) + cands name level marker) + (save-excursion + (setq counsel-outline--preselect 0) + (goto-char (point-min)) + (while (re-search-forward bol-regex nil t) + (save-excursion + (setq name (or (save-match-data + (funcall outline-title-fn)) + "")) + (goto-char (match-beginning 0)) + (setq marker (point-marker)) + (setq level (funcall outline-level-fn)) + (cond ((eq display-style 'path) + ;; Update stack. The empty entry guards against incorrect + ;; headline hierarchies, e.g. a level 3 headline + ;; immediately following a level 1 entry. + (while (<= level stack-level) + (pop stack) + (cl-decf stack-level)) + (while (> level stack-level) + (push "" stack) + (cl-incf stack-level)) + (setf (car stack) + (counsel-outline--add-face + name level face-style custom-faces)) + (setq name (mapconcat #'identity + (reverse stack) + path-separator))) + (t + (when (eq display-style 'headline) + (setq name (concat (make-string level ?*) " " name))) + (setq name (counsel-outline--add-face + name level face-style custom-faces)))) + (push (cons name marker) cands)) + (unless (or (string= name "") + (< orig-point marker)) + (cl-incf counsel-outline--preselect)))) + (nreverse cands))) + +(defun counsel-outline--add-face (name level &optional face-style custom-faces) + "Set the `face' property on headline NAME according to LEVEL. +FACE-STYLE and CUSTOM-FACES override `counsel-outline-face-style' +and `counsel-outline-custom-faces', respectively, which determine +the face to apply." + (let ((face (cl-case (or face-style counsel-outline-face-style) + (verbatim) + (custom (nth (1- level) + (or custom-faces counsel-outline-custom-faces))) + (org (format "counsel-outline-%d" level)) + (t 'counsel-outline-default)))) + (when face + (put-text-property 0 (length name) 'face face name))) + name) + +(defun counsel-outline-action (x) + "Go to outline X." + (goto-char (cdr x))) + +;;;###autoload +(defun counsel-outline () + "Jump to an outline heading with completion." + (interactive) + (let ((settings (cdr (assq major-mode counsel-outline-settings)))) + (ivy-read "Outline: " (counsel-outline-candidates settings) + :action (or (plist-get settings :action) + #'counsel-outline-action) + :history (or (plist-get settings :history) + 'counsel-outline-history) + :preselect (max (1- counsel-outline--preselect) 0) + :caller (or (plist-get settings :caller) + 'counsel-outline)))) + +;;;; `counsel-ibuffer' + +(defvar counsel-ibuffer--buffer-name nil + "Name of the buffer to use for `counsel-ibuffer'.") + +;;;###autoload +(defun counsel-ibuffer (&optional name) + "Use ibuffer to switch to another buffer. +NAME specifies the name of the buffer (defaults to \"*Ibuffer*\")." + (interactive) + (setq counsel-ibuffer--buffer-name (or name "*Ibuffer*")) + (ivy-read "Switch to buffer: " (counsel--ibuffer-get-buffers) + :history 'counsel-ibuffer-history + :action #'counsel-ibuffer-visit-buffer + :caller 'counsel-ibuffer)) + +(declare-function ibuffer-update "ibuffer") +(declare-function ibuffer-current-buffer "ibuffer") +(declare-function ibuffer-forward-line "ibuffer") +(defvar ibuffer-movement-cycle) + +(defun counsel--ibuffer-get-buffers () + "Return an alist with buffer completion candidates from Ibuffer. +The keys are buffer-related lines from Ibuffer as strings, and +the values are the corresponding buffer objects." + (let ((oldbuf (get-buffer counsel-ibuffer--buffer-name))) + (unless oldbuf + ;; Avoid messing with the user's precious window/frame configuration. + (save-window-excursion + (let ((display-buffer-overriding-action + '(display-buffer-same-window (inhibit-same-window . nil)))) + (ibuffer nil counsel-ibuffer--buffer-name nil t)))) + (with-current-buffer counsel-ibuffer--buffer-name + (when oldbuf + ;; Forcibly update possibly stale existing buffer. + (ibuffer-update nil t)) + (goto-char (point-min)) + (let ((ibuffer-movement-cycle nil) + entries) + (while (not (eobp)) + (ibuffer-forward-line 1 t) + (let ((buf (ibuffer-current-buffer))) + ;; We are only interested in buffers we can actually visit. + ;; This filters out headings and other unusable entries. + (when (buffer-live-p buf) + (push (cons (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)) + buf) + entries)))) + (nreverse entries))))) + +(defun counsel-ibuffer-visit-buffer (x) + "Switch to buffer of candidate X." + (switch-to-buffer (or (cdr-safe x) x))) + +(defun counsel-ibuffer-visit-buffer-other-window (x) + "Switch to buffer of candidate X in another window." + (switch-to-buffer-other-window (or (cdr-safe x) x))) + +(defun counsel-ibuffer-visit-ibuffer (_) + "Switch to Ibuffer buffer." + (switch-to-buffer counsel-ibuffer--buffer-name)) + +(ivy-set-actions + 'counsel-ibuffer + '(("j" counsel-ibuffer-visit-buffer-other-window "other window") + ("v" counsel-ibuffer-visit-ibuffer "switch to Ibuffer"))) + +;;;; `counsel-switch-to-shell-buffer' + +(defun counsel--buffers-with-mode (mode) + "Return names of buffers with MODE as their `major-mode'." + (let (bufs) + (dolist (buf (buffer-list)) + (when (eq (buffer-local-value 'major-mode buf) mode) + (push (buffer-name buf) bufs))) + (nreverse bufs))) + +(declare-function shell-mode "shell") + +;;;###autoload +(defun counsel-switch-to-shell-buffer () + "Switch to a shell buffer, or create one." + (interactive) + (ivy-read "Shell buffer: " (counsel--buffers-with-mode #'shell-mode) + :action #'counsel--switch-to-shell + :caller 'counsel-switch-to-shell-buffer)) + +(defun counsel--switch-to-shell (name) + "Display shell buffer with NAME and select its window. +Reuse any existing window already displaying the named buffer. +If there is no such buffer, start a new `shell' with NAME." + (if (get-buffer name) + (pop-to-buffer name '((display-buffer-reuse-window + display-buffer-same-window) + (inhibit-same-window . nil) + (reusable-frames . visible))) + (shell name))) + +;;;; `counsel-unicode-char' + +(defvar counsel-unicode-char-history nil + "History for `counsel-unicode-char'.") + +(defun counsel--unicode-names () + "Return formatted and sorted list of `ucs-names'. +The result of `ucs-names' is mostly, but not completely, sorted, +so this function ensures lexicographic order." + (let* (cands + (table (ucs-names)) ; Either hash map or alist + (fmt (lambda (name code) ; Common format function + (let ((cand (format "%06X %-58s %c" code name code))) + (put-text-property 0 1 'code code cand) + (push cand cands))))) + (if (not (hash-table-p table)) + ;; Support `ucs-names' returning an alist in Emacs < 26. + ;; The result of `ucs-names' comes pre-reversed so no need to repeat. + (dolist (entry table) + (funcall fmt (car entry) (cdr entry))) + (maphash fmt table) + ;; Reverse to speed up sorting + (setq cands (nreverse cands))) + (sort cands #'string-lessp))) + +(defvar counsel--unicode-table + (lazy-completion-table counsel--unicode-table counsel--unicode-names) + "Lazy completion table for `counsel-unicode-char'. +Candidates comprise `counsel--unicode-names', which see.") + +;;;###autoload +(defun counsel-unicode-char (&optional count) + "Insert COUNT copies of a Unicode character at point. +COUNT defaults to 1." + (interactive "p") + (setq ivy-completion-beg (point)) + (setq ivy-completion-end (point)) + (ivy-read "Unicode name: " counsel--unicode-table + :history 'counsel-unicode-char-history + :action (lambda (name) + (with-ivy-window + (delete-region ivy-completion-beg ivy-completion-end) + (setq ivy-completion-beg (point)) + (insert-char (get-text-property 0 'code name) count) + (setq ivy-completion-end (point)))) + :caller 'counsel-unicode-char)) + +(ivy-configure 'counsel-unicode-char + :sort-fn #'ivy-string<) + +(defun counsel-unicode-copy (name) + "Ivy action to copy the unicode from NAME to the kill ring." + (kill-new (char-to-string (get-text-property 0 'code name)))) + +(ivy-set-actions + 'counsel-unicode-char + '(("w" counsel-unicode-copy "copy"))) + +;;;; Colors + +(defun counsel-colors-action-insert-hex (color) + "Insert the hexadecimal RGB value of COLOR." + (insert (get-text-property 0 'hex color))) + +(defun counsel-colors-action-kill-hex (color) + "Kill the hexadecimal RGB value of COLOR." + (kill-new (get-text-property 0 'hex color))) + +;;;;; `counsel-colors-emacs' + +(defvar counsel-colors-emacs-history () + "History for `counsel-colors-emacs'.") + +(defun counsel-colors--name-to-hex (name) + "Return hexadecimal RGB value of color with NAME. + +Return nil if NAME does not designate a valid color." + (let ((rgb (color-name-to-rgb name))) + (when rgb + (apply #'color-rgb-to-hex rgb)))) + +(defvar shr-color-visible-luminance-min) +(declare-function shr-color-visible "shr-color") +(defvar counsel--colors-format "%-20s %s %s%s") + +(defun counsel--colors-emacs-format-function (colors) + "Format function for `counsel-colors-emacs'." + (require 'shr-color) + (let* ((blank (make-string 10 ?\s)) + (formatter + (lambda (color) + (let ((fg (list :foreground color))) + (format counsel--colors-format color + (propertize (get-text-property 0 'hex color) 'face fg) + (propertize blank 'face (list :background color)) + (propertize (mapconcat (lambda (dup) + (concat " " dup)) + (get-text-property 0 'dups color) + ",") + 'face fg)))))) + (ivy--format-function-generic + (lambda (color) + (let* ((hex (get-text-property 0 'hex color)) + (shr-color-visible-luminance-min 100) + (fg (cadr (shr-color-visible hex "black" t)))) + (propertize (funcall formatter color) + 'face (list :foreground fg :background hex)))) + formatter colors "\n"))) + +(defun counsel--colors-web-format-function (colors) + "Format function for `counsel-colors-web'." + (require 'shr-color) + (let* ((blank (make-string 10 ?\s)) + (formatter (lambda (color) + (let ((hex (get-text-property 0 'hex color))) + (format counsel--colors-format color + (propertize hex 'face (list :foreground hex)) + (propertize blank 'face (list :background hex))))))) + (ivy--format-function-generic + (lambda (color) + (let* ((hex (get-text-property 0 'hex color)) + (shr-color-visible-luminance-min 100) + (fg (cadr (shr-color-visible hex "black" t)))) + (propertize (funcall formatter color) + 'face (list :foreground fg :background hex)))) + formatter colors "\n"))) + +;; No longer preloaded in Emacs 28. +(autoload 'list-colors-duplicates "facemenu") + +;;;###autoload +(defun counsel-colors-emacs () + "Show a list of all supported colors for a particular frame. + +You can insert or kill the name or hexadecimal RGB value of the +selected color." + (interactive) + (let* ((colors + (delete nil + (mapcar (lambda (cell) + (let* ((name (car cell)) + (dups (cdr cell)) + (hex (counsel-colors--name-to-hex name))) + (when hex + (propertize name 'hex hex 'dups dups)))) + (list-colors-duplicates)))) + (counsel--colors-format + (format "%%-%ds %%s %%s%%s" + (apply #'max 0 (mapcar #'string-width colors))))) + (ivy-read "Emacs color: " colors + :require-match t + :history 'counsel-colors-emacs-history + :action #'insert + :caller 'counsel-colors-emacs))) +(ivy-configure 'counsel-colors-emacs + :format-fn #'counsel--colors-emacs-format-function) + +(ivy-set-actions + 'counsel-colors-emacs + '(("h" counsel-colors-action-insert-hex "insert hexadecimal value") + ("H" counsel-colors-action-kill-hex "kill hexadecimal value"))) + +;;;;; `counsel-colors-web' + +(defvar shr-color-html-colors-alist) + +(defun counsel-colors--web-alist () + "Return list of CSS colors for `counsel-colors-web'." + (require 'shr-color) + (let* ((alist (copy-alist shr-color-html-colors-alist)) + (mp (assoc "MediumPurple" alist)) + (pvr (assoc "PaleVioletRed" alist)) + (rp (assoc "RebeccaPurple" alist))) + ;; Backport GNU Emacs bug#30377 + (when mp (setcdr mp "#9370db")) + (when pvr (setcdr pvr "#db7093")) + (unless rp (push (cons "rebeccapurple" "#663399") alist)) + (sort (mapcar (lambda (cell) + (propertize (downcase (car cell)) + 'hex (downcase (cdr cell)))) + alist) + #'string-lessp))) + +(defvar counsel-colors-web-history () + "History for `counsel-colors-web'.") + +;;;###autoload +(defun counsel-colors-web () + "Show a list of all W3C web colors for use in CSS. + +You can insert or kill the name or hexadecimal RGB value of the +selected color." + (interactive) + (let* ((colors (counsel-colors--web-alist)) + (counsel--colors-format + (format "%%-%ds %%s %%s" + (apply #'max 0 (mapcar #'string-width colors))))) + (ivy-read "Web color: " colors + :require-match t + :history 'counsel-colors-web-history + :action #'insert + :caller 'counsel-colors-web))) + +(ivy-configure 'counsel-colors-web + :sort-fn #'ivy-string< + :format-fn #'counsel--colors-web-format-function) + +(ivy-set-actions + 'counsel-colors-web + '(("h" counsel-colors-action-insert-hex "insert hexadecimal value") + ("H" counsel-colors-action-kill-hex "kill hexadecimal value"))) + +;;;; `counsel-fonts' + +(defvar counsel-fonts-history () + "History for `counsel-fonts'.") + +;;;###autoload +(defun counsel-fonts () + "Show a list of all supported font families for a particular frame. + +You can insert or kill the name of the selected font." + (interactive) + (let ((current-font + (symbol-name (font-get (face-attribute 'default :font) :family)))) + (ivy-read "Font: " (delete-dups (font-family-list)) + :preselect current-font + :require-match t + :history 'counsel-fonts-history + :action #'insert + :caller 'counsel-fonts))) + +(ivy-configure 'counsel-fonts + :display-transformer-fn #'counsel--font-with-sample) + +(defun counsel--font-with-sample (font-name) + "Format function for `counsel-fonts'." + (format "%-75s%s" font-name + (propertize "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + 'face (list :family font-name)))) + +;;;; `counsel-kmacro' + +(defvar counsel-kmacro-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-k") #'counsel-kmacro-kill) + map)) + +;; Avoid (declare (modes ...)) warnings in Emacs < 28. +(function-put #'counsel-kmacro-kill 'command-modes '(minibuffer-mode)) +(defun counsel-kmacro-kill () + "Kill the line, or delete the currently selected keyboard macro." + (interactive) + (unless (window-minibuffer-p) + (user-error "No completion session is active")) + (if (not (eolp)) + (ivy-kill-line) + (counsel-kmacro-action-delete-kmacro + (assoc + (ivy-state-current ivy-last) + (ivy-state-collection ivy-last))) + (ivy--kill-current-candidate))) + +(defvar kmacro-counter) +(defvar kmacro-counter-format-start) +(defvar kmacro-ring) +(declare-function kmacro-cycle-ring-next "kmacro" (&optional arg)) +(declare-function kmacro-cycle-ring-previous "kmacro" (&optional arg)) +(declare-function kmacro-delete-ring-head "kmacro" (&optional arg)) +(declare-function kmacro-ring-head "kmacro" ()) +(declare-function kmacro-set-counter "kmacro" (arg)) +(declare-function kmacro-set-format "kmacro" (format)) +(declare-function kmacro-split-ring-element "kmacro" (elt)) + +;;;###autoload +(defun counsel-kmacro () + "Interactively choose and execute a keyboard macro. + +With a prefix argument, execute the macro that many times. + +Macros are executed using their respective `kmacro-counter' value and +counter format; these values are also displayed next to each completion +candidate. + +The default actions include the ability to copy one macro's counter +value or format as the basis for another macro execution or definition. + +The following key bindings are also available: +\\{counsel-kmacro-map}" + (interactive) + (require 'kmacro) + (ivy-read "Execute macro: " + (or (counsel--kmacro-candidates) + (user-error "No keyboard macros defined")) + :keymap counsel-kmacro-map + :require-match t + :action #'counsel-kmacro-action-run + :caller 'counsel-kmacro)) + +(ivy-configure 'counsel-kmacro + :format-fn #'counsel--kmacro-format-function) + +(defcustom counsel-kmacro-separator "\n------------------------\n" + "Separator displayed between keyboard macros in `counsel-kmacro'." + :type 'string) + +(defun counsel--kmacro-format-function (formatted-kmacro) + "Transform FORMATTED-KMACRO into a string for `counsel-kmacro'." + (ivy--format-function-generic + (lambda (str) (ivy--add-face str 'ivy-current-match)) + #'identity + formatted-kmacro + (propertize counsel-kmacro-separator 'face 'ivy-separator))) + +(defmacro counsel--with-kmacro (kmacro &rest body) + "Split KMACRO slots into corresponding dynvars around BODY." + (declare (debug t) (indent 1)) + `(let ((last-kbd-macro nil) + (kmacro-counter nil) + (kmacro-counter-format-start nil)) + ;; Works with both older triplets and Emacs 29 OClosures. + (kmacro-split-ring-element ,kmacro) + ,@body)) + +(defun counsel--format-kmacro () + "Return string representation of current keyboard macro." + (format "(%s,%s): %s" kmacro-counter-format-start kmacro-counter + (condition-case err + (format-kbd-macro last-kbd-macro 1) + ;; Recover from error in `edmacro-fix-menu-commands', + ;; especially prior to mouse event support in Emacs 27. + (error + (format (propertize "[Unprintable macro: %s]" 'face 'warning) + (error-message-string err)))))) + +(defun counsel--kmacro-candidates () + "Return an alist of known keyboard macros for `counsel-kmacro'. +The cdrs are the original `kmacro' objects from `kmacro-ring-head' and +`kmacro-ring'; the cars are a corresponding string representation." + (mapcar (lambda (km) + (cons (counsel--with-kmacro km + (counsel--format-kmacro)) + km)) + (let ((head (kmacro-ring-head))) + (and head (cons head kmacro-ring))))) + +(defun counsel--kmacro-exec (kmacro n) + "Execute KMACRO ring item N times." + (funcall (if (and (fboundp 'kmacro-p) (kmacro-p kmacro)) + #'funcall ;; Emacs 29 OClosure. + 'kmacro-exec-ring-item) + kmacro n)) + +(defun counsel-kmacro-action-run (candidate) + "Execute keyboard macro from `counsel-kmacro' CANDIDATE. +With a prefix argument, execute the macro that many times." + ;; Action prefix overrides `counsel-kmacro' prefix. + (let* ((pre (or ivy-current-prefix-arg current-prefix-arg)) + (km (cdr candidate)) + (head (equal km (kmacro-ring-head)))) + (counsel--kmacro-exec km (prefix-numeric-value pre)) + (when head + ;; Executing pseudo `kmacro-ring-head' updates that object's counter, + ;; but not the current `kmacro-counter', so reconcile them here. + (kmacro-split-ring-element km)) + ;; Update state for next `ivy-call'. + (counsel--with-kmacro km + (setcar candidate (counsel--format-kmacro)))) + (setf (ivy-state-current ivy-last) (car candidate)) + (setf (ivy-state-preselect ivy-last) ivy--index) + (ivy--reset-state ivy-last)) + +(defun counsel-kmacro-action-delete-kmacro (candidate) + "Delete the keyboard macro in `counsel-kmacro' CANDIDATE. +Either delete it from `kmacro-ring', or set `last-kbd-macro' +to the popped head of the ring." + (let ((km (cdr candidate))) + (if (memq km kmacro-ring) + (setq kmacro-ring (delq km kmacro-ring)) + (kmacro-delete-ring-head))) + ;; Update state for next `ivy-call'. + ;; TODO: Is `ivy--kill-current-candidate' required? + (let ((kms (ivy-state-collection ivy-last))) + (setf (ivy-state-collection ivy-last) (delq candidate kms)) + (setf (ivy-state-preselect ivy-last) + (max 0 (min ivy--index (1- (length kms)))))) + (ivy--reset-state ivy-last)) + +(defun counsel-kmacro-action-copy-initial-counter-value (candidate) + "Pass `counsel-kmacro' CANDIDATE's counter value to `kmacro-set-counter'. +This value will be used by the next executed macro, or as a +starting value by the next macro defined. + +Note that executing an existing macro that itself uses a counter +effectively resets the starting counter value for the next macro +definition to 0." + (kmacro-set-counter (counsel--with-kmacro (cdr candidate) + kmacro-counter))) + +(defun counsel-kmacro-action-copy-counter-format-for-new-macro (candidate) + "Pass `counsel-kmacro' CANDIDATE's counter format to `kmacro-set-format'. + +When no keyboard macro is being defined or executed, this affects the +default for all subsequent macro definitions." + (kmacro-set-format (counsel--with-kmacro (cdr candidate) + kmacro-counter-format-start))) + +(defun counsel--kmacro-cycle-until (kmacro) + "Cycle macro ring until KMACRO is the head; return number of steps." + (let ((i 0) + ;; Purely defensive; infloop should never happen. + ;; Purely defensive; infloop should never happen. + ;; Purely defensive; infloop should never happen.[Quit] + (fuel (* 4 (1+ (length kmacro-ring))))) + (while (not (equal kmacro (kmacro-ring-head))) + (unless (natnump (cl-decf fuel)) + (error "`counsel-kmacro' bug: exceeded cycle limit")) + (kmacro-cycle-ring-previous) + (cl-incf i)) + i)) + +(defun counsel-kmacro-action-cycle-ring-to-macro (candidate) + "Cycle `kmacro-ring' until `last-kbd-macro' is the selected macro. +This is convenient when using \\[kmacro-end-or-call-macro] to call macros." + (counsel--kmacro-cycle-until (cdr candidate)) + ;; Update state for next `ivy-call'. + (setf (ivy-state-collection ivy-last) (counsel--kmacro-candidates)) + (ivy--reset-state ivy-last)) + +(defun counsel-kmacro-action-set-saved-starting-counter (candidate) + "Set the counter value of `counsel-kmacro' CANDIDATE. +Interactively reads a new counter value from the minibuffer. + +Note that this requires cycling the keyboard macro ring until CANDIDATE, +and then cycling back." + (let* ((km (cdr candidate)) + (cnt (counsel--with-kmacro km kmacro-counter)) + (cnt (if (zerop cnt) cnt (list 0 cnt))) + (i (counsel--kmacro-cycle-until km))) + (setq kmacro-counter (read-number "New macro counter: " cnt)) + (dotimes (_ i) (kmacro-cycle-ring-next))) + ;; Update state for next `ivy-call'. + (setf (ivy-state-collection ivy-last) (counsel--kmacro-candidates)) + (setf (ivy-state-preselect ivy-last) ivy--index) + ;; Emacs 28 seems to have some bug where the text of the candidates + ;; in the minibuffer is not immediately refreshed. + (ivy--reset-state ivy-last)) + +(defun counsel-kmacro-action-execute-after-prompt (candidate) + "Execute selected keyboard macro with a different counter and format. + +Prompt for the number of times to execute the macro, the starting +counter, and the counter format. The corresponding values from the +selected `counsel-kmacro' CANDIDATE serve as defaults. If this action +is called with a prefix argument, its numeric value also serves as a +default option for the number of iterations and counter. + +The existing CANDIDATE, its counter and format, are left unchanged." + (let* ((pre (or ivy-current-prefix-arg current-prefix-arg)) + (pre (and pre (prefix-numeric-value pre)))) + (counsel--with-kmacro (cdr candidate) + (let ((times (read-number "Number of macro iterations: " + (let ((def '(1 2))) + (if pre (cons pre def) def))))) + (setq kmacro-counter + (read-number "Macro counter value: " + (if pre (list pre kmacro-counter) kmacro-counter))) + (setq kmacro-counter-format-start + (let ((prompt "Macro counter format") + (def kmacro-counter-format-start)) + (read-string (if (fboundp 'format-prompt) + (format-prompt prompt def) + (format "%s (default: %s): " prompt def)) + nil nil def))) + (counsel--kmacro-exec (kmacro-ring-head) times))))) + +(ivy-set-actions + 'counsel-kmacro + `(("c" ,#'counsel-kmacro-action-cycle-ring-to-macro + "cycle to") + ("d" ,#'counsel-kmacro-action-delete-kmacro + "delete") + ("e" ,#'counsel-kmacro-action-execute-after-prompt + "execute after prompt") + ("f" ,#'counsel-kmacro-action-copy-counter-format-for-new-macro + "copy counter format for new macro") + ("s" ,#'counsel-kmacro-action-set-saved-starting-counter + "set this counter value") + ("v" ,#'counsel-kmacro-action-copy-initial-counter-value + "copy starting counter value"))) + +;;;; `counsel-geiser-doc-look-up-manual' + +(declare-function geiser-doc-manual-for-symbol "ext:geiser-doc") +(defvar geiser-completion-symbol-list-func) + +(defvar counsel-geiser-doc-look-up-manual-history () + "History for `counsel-geiser-doc-look-up-manual'.") + +;;;###autoload +(defun counsel-geiser-doc-look-up-manual () + "Search Scheme documentation." + (interactive) + (ivy-read "Symbol: " geiser-completion-symbol-list-func + :require-match t + :history 'counsel-geiser-doc-look-up-manual-history + :action (lambda (cand) + (geiser-doc-manual-for-symbol (intern cand))) + :caller 'counsel-geiser-doc-look-up-manual)) + +;;; Misc. OS +;;;; `counsel-rhythmbox' + +(declare-function dbus-call-method "dbus") +(declare-function dbus-get-property "dbus") + +(defun counsel--run (&rest program-and-args) + (let ((name (mapconcat #'identity program-and-args " "))) + (apply #'start-process name nil program-and-args) + name)) + +(defun counsel--sl (cmd) + "Shell command to list." + (split-string (shell-command-to-string cmd) "\n" t)) + +(defun counsel-rhythmbox-play-song (song) + "Let Rhythmbox play SONG." + (let ((first (string= (shell-command-to-string "pidof rhythmbox") "")) + (service "org.gnome.Rhythmbox3") + (path "/org/mpris/MediaPlayer2") + (interface "org.mpris.MediaPlayer2.Player")) + (when first + (counsel--run "nohup" "rhythmbox") + (sit-for 1.5)) + (dbus-call-method :session service path interface + "OpenUri" (cdr song)) + (let ((id (and first + (cdr (counsel--wmctrl-parse + (shell-command-to-string + "wmctrl -l -p | grep $(pidof rhythmbox)")))))) + (when id + (sit-for 0.2) + (counsel--run "wmctrl" "-ic" id))))) + +(defun counsel-rhythmbox-enqueue-song (song) + "Let Rhythmbox enqueue SONG." + (let ((service "org.gnome.Rhythmbox3") + (path "/org/gnome/Rhythmbox3/PlayQueue") + (interface "org.gnome.Rhythmbox3.PlayQueue")) + (dbus-call-method :session service path interface + "AddToQueue" (cdr song)))) + +(defun counsel-rhythmbox-playpause-current-song () + "Play/pause the current song." + (interactive) + (let ((service "org.gnome.Rhythmbox3") + (path "/org/mpris/MediaPlayer2") + (interface "org.mpris.MediaPlayer2.Player")) + (dbus-call-method :session service path interface + "PlayPause"))) + +(defun counsel-rhythmbox-toggle-shuffle (_song) + "Toggle Rhythmbox shuffle setting." + (let* ((old-order (counsel--command "dconf" "read" "/org/gnome/rhythmbox/player/play-order")) + (new-order (if (string= old-order "'shuffle'") + "'linear'" + "'shuffle'"))) + (counsel--command + "dconf" + "write" + "/org/gnome/rhythmbox/player/play-order" + new-order) + (message (if (string= new-order "'shuffle'") + "shuffle on" + "shuffle off")))) + +(defvar counsel-rhythmbox-history nil + "History for `counsel-rhythmbox'.") + +(defvar counsel-rhythmbox-songs nil) + +(defun counsel-rhythmbox-current-song () + "Return the currently playing song title." + (ignore-errors + (let* ((entry (dbus-get-property + :session + "org.mpris.MediaPlayer2.rhythmbox" + "/org/mpris/MediaPlayer2" + "org.mpris.MediaPlayer2.Player" + "Metadata")) + (artist (caar (cadr (assoc "xesam:artist" entry)))) + (album (cl-caadr (assoc "xesam:album" entry))) + (title (cl-caadr (assoc "xesam:title" entry)))) + (format "%s - %s - %s" artist album title)))) + +;;;###autoload +(defun counsel-rhythmbox (&optional arg) + "Choose a song from the Rhythmbox library to play or enqueue." + (interactive "P") + (require 'dbus) + (when (or arg (null counsel-rhythmbox-songs)) + (let* ((service "org.gnome.Rhythmbox3") + (path "/org/gnome/UPnP/MediaServer2/Library/all") + (interface "org.gnome.UPnP.MediaContainer2") + (nb-songs (dbus-get-property + :session service path interface "ChildCount"))) + (if (not nb-songs) + (error "Couldn't connect to Rhythmbox") + (setq counsel-rhythmbox-songs + (mapcar (lambda (x) + (cons + (format + "%s - %s - %s" + (cl-caadr (assoc "Artist" x)) + (cl-caadr (assoc "Album" x)) + (cl-caadr (assoc "DisplayName" x))) + (cl-caaadr (assoc "URLs" x)))) + (dbus-call-method + :session service path interface "ListChildren" + 0 nb-songs '("*"))))))) + (ivy-read "Rhythmbox: " counsel-rhythmbox-songs + :require-match t + :history 'counsel-rhythmbox-history + :preselect (counsel-rhythmbox-current-song) + :action + '(1 + ("p" counsel-rhythmbox-play-song "Play song") + ("e" counsel-rhythmbox-enqueue-song "Enqueue song") + ("s" counsel-rhythmbox-toggle-shuffle "Shuffle on/off")) + :caller 'counsel-rhythmbox)) + +;;;; `counsel-linux-app' + +;; Added in Emacs 26.1. +(require 'xdg nil t) + +(defalias 'counsel--xdg-data-home + (if (fboundp 'xdg-data-home) + #'xdg-data-home + (lambda () + (let ((directory (getenv "XDG_DATA_HOME"))) + (if (or (null directory) (string= directory "")) + "~/.local/share" + directory)))) + "Compatibility shim for `xdg-data-home'.") + +(defalias 'counsel--xdg-data-dirs + (if (fboundp 'xdg-data-dirs) + #'xdg-data-dirs + (lambda () + (let ((path (getenv "XDG_DATA_DIRS"))) + (if (or (null path) (string= path "")) + '("/usr/local/share" "/usr/share") + (parse-colon-path path))))) + "Compatibility shim for `xdg-data-dirs'.") + +(defcustom counsel-linux-apps-directories + (mapcar (lambda (dir) (expand-file-name "applications" dir)) + (cons (counsel--xdg-data-home) + (counsel--xdg-data-dirs))) + "Directories in which to search for applications (.desktop files)." + :type '(repeat directory)) + +(defcustom counsel-linux-app-format-function #'counsel-linux-app-format-function-default + "Function to format Linux application names the `counsel-linux-app' menu. +The format function will be passed the application's name, comment, and command +as arguments." + :type '(choice + (const :tag "Command : Name - Comment" counsel-linux-app-format-function-default) + (const :tag "Name - Comment (Command)" counsel-linux-app-format-function-name-first) + (const :tag "Name - Comment" counsel-linux-app-format-function-name-only) + (const :tag "Name - Comment (Pretty)" counsel-linux-app-format-function-name-pretty) + (const :tag "Command" counsel-linux-app-format-function-command-only) + (function :tag "Custom"))) + +(defface counsel-application-name + '((t :inherit font-lock-builtin-face)) + "Face for displaying executable names." + :group 'ivy-faces) + +(defface counsel-outline-1 + '((t :inherit org-level-1)) + "Face for displaying level 1 headings." + :group 'ivy-faces) + +(defface counsel-outline-2 + '((t :inherit org-level-2)) + "Face for displaying level 2 headings." + :group 'ivy-faces) + +(defface counsel-outline-3 + '((t :inherit org-level-3)) + "Face for displaying level 3 headings." + :group 'ivy-faces) + +(defface counsel-outline-4 + '((t :inherit org-level-4)) + "Face for displaying level 4 headings." + :group 'ivy-faces) + +(defface counsel-outline-5 + '((t :inherit org-level-5)) + "Face for displaying level 5 headings." + :group 'ivy-faces) + +(defface counsel-outline-6 + '((t :inherit org-level-6)) + "Face for displaying level 6 headings." + :group 'ivy-faces) + +(defface counsel-outline-7 + '((t :inherit org-level-7)) + "Face for displaying level 7 headings." + :group 'ivy-faces) + +(defface counsel-outline-8 + '((t :inherit org-level-8)) + "Face for displaying level 8 headings." + :group 'ivy-faces) + +(defface counsel-outline-default + '((t :inherit minibuffer-prompt)) + "Face for displaying headings." + :group 'ivy-faces) + +(defvar counsel-linux-apps-faulty nil + "List of faulty desktop files.") + +(defvar counsel--linux-apps-cache nil + "Cache of desktop files data.") + +(defvar counsel--linux-apps-cached-files nil + "List of cached desktop files.") + +(defvar counsel--linux-apps-cache-timestamp nil + "Time when we last updated the cached application list.") + +(defvar counsel--linux-apps-cache-format-function nil + "The function used to format the cached Linux application menu.") + +(defun counsel-linux-app-format-function-default (name comment exec) + "Default Linux application name formatter. +NAME is the name of the application, COMMENT its comment and EXEC +the command to launch it." + (format "% -45s: %s%s" + (propertize + (ivy--truncate-string + (replace-regexp-in-string "env +[^ ]+ +" "" exec t t) + 45) + 'face 'counsel-application-name) + name + (if comment + (concat " - " comment) + ""))) + +(defun counsel-linux-app-format-function-name-first (name comment exec) + "Format Linux application names with the NAME (and COMMENT) first. +EXEC is the command to launch the application." + (format "%s%s (%s)" + name + (if comment + (concat " - " comment) + "") + (propertize exec 'face 'counsel-application-name))) + +(defun counsel-linux-app-format-function-name-only (name comment _exec) + "Format Linux application names with the NAME (and COMMENT) only." + (format "%s%s" + name + (if comment + (concat " - " comment) + ""))) + +(defun counsel-linux-app-format-function-command-only (_name _comment exec) + "Display only the command EXEC when formatting Linux application names." + exec) + +(defun counsel-linux-app-format-function-name-pretty (name comment _exec) + "Format Linux application names with the NAME (and COMMENT) only, but pretty." + (format "% -45s%s" + (propertize + (ivy--truncate-string name 45) + 'face 'counsel-application-name) + (if comment + (concat ": " comment) + ""))) + +(defun counsel-linux-apps-list-desktop-files () + "Return an alist of all Linux applications. +Each list entry is a pair of (desktop-name . desktop-file). +This function always returns its elements in a stable order." + (let ((hash (make-hash-table :test #'equal)) + result) + (dolist (dir counsel-linux-apps-directories) + (when (file-exists-p dir) + (let ((dir (file-name-as-directory dir))) + ;; Function `directory-files-recursively' added in Emacs 25.1. + (dolist (file (and (fboundp 'directory-files-recursively) + (directory-files-recursively dir "\\.desktop\\'"))) + (let ((id (subst-char-in-string ?/ ?- (file-relative-name file dir)))) + (when (and (not (gethash id hash)) (file-readable-p file)) + (push (cons id file) result) + (puthash id file hash))))))) + result)) + +(defun counsel-linux-app--parse-file (file) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (let ((start (re-search-forward "^\\[Desktop Entry\\] *$" nil t)) + (end (re-search-forward "^\\[" nil t)) + (visible t) + name comment exec) + (catch 'break + (unless start + (push file counsel-linux-apps-faulty) + (message "Warning: File %s has no [Desktop Entry] group" file) + (throw 'break nil)) + + (goto-char start) + (when (re-search-forward "^\\(Hidden\\|NoDisplay\\) *= *\\(1\\|true\\) *$" end t) + (setq visible nil)) + (setq name (match-string 1)) + + (goto-char start) + (unless (re-search-forward "^Type *= *Application *$" end t) + (throw 'break nil)) + (setq name (match-string 1)) + + (goto-char start) + (unless (re-search-forward "^Name *= *\\(.+\\)$" end t) + (push file counsel-linux-apps-faulty) + (message "Warning: File %s has no Name" file) + (throw 'break nil)) + (setq name (match-string 1)) + + (goto-char start) + (when (re-search-forward "^Comment *= *\\(.+\\)$" end t) + (setq comment (match-string 1))) + + (goto-char start) + (unless (re-search-forward "^Exec *= *\\(.+\\)$" end t) + ;; Don't warn because this can technically be a valid desktop file. + (throw 'break nil)) + (setq exec (match-string 1)) + + (goto-char start) + (when (re-search-forward "^TryExec *= *\\(.+\\)$" end t) + (let ((try-exec (match-string 1))) + (unless (locate-file try-exec exec-path nil #'file-executable-p) + (throw 'break nil)))) + (propertize + (funcall counsel-linux-app-format-function name comment exec) + 'visible visible))))) + +(defun counsel-linux-apps-parse (desktop-entries-alist) + "Parse the given alist of Linux desktop entries. +Each entry in DESKTOP-ENTRIES-ALIST is a pair of ((id . file-name)). +Any desktop entries that fail to parse are recorded in +`counsel-linux-apps-faulty'." + (let (result) + (setq counsel-linux-apps-faulty nil) + (dolist (entry desktop-entries-alist result) + (let* ((id (car entry)) + (file (cdr entry)) + (r (counsel-linux-app--parse-file file))) + (when r + (push (cons r id) result)))))) + +(defun counsel-linux-apps-list () + "Return list of all Linux desktop applications." + (let* ((new-desktop-alist (counsel-linux-apps-list-desktop-files)) + (new-files (mapcar #'cdr new-desktop-alist))) + (unless (and + (eq counsel-linux-app-format-function + counsel--linux-apps-cache-format-function) + (equal new-files counsel--linux-apps-cached-files) + (null (cl-find-if + (lambda (file) + (time-less-p + counsel--linux-apps-cache-timestamp + (nth 5 (file-attributes file)))) + new-files))) + (setq counsel--linux-apps-cache (counsel-linux-apps-parse new-desktop-alist)) + (setq counsel--linux-apps-cache-format-function counsel-linux-app-format-function) + (setq counsel--linux-apps-cache-timestamp (current-time)) + (setq counsel--linux-apps-cached-files new-files))) + counsel--linux-apps-cache) + + +(defun counsel-linux-app-action-default (desktop-shortcut) + "Launch DESKTOP-SHORTCUT." + (call-process "gtk-launch" nil 0 nil (cdr desktop-shortcut))) + +(defun counsel-linux-app-action-file (desktop-shortcut) + "Launch DESKTOP-SHORTCUT with a selected file." + (call-process "gtk-launch" nil 0 nil + (cdr desktop-shortcut) + (read-file-name "File: "))) + +(defun counsel-linux-app-action-open-desktop (desktop-shortcut) + "Open DESKTOP-SHORTCUT." + (let* ((app (cdr desktop-shortcut)) + (file (cdr (assoc app (counsel-linux-apps-list-desktop-files))))) + (if file + (find-file file) + (error "Could not find location of file %s" app)))) + +(ivy-set-actions + 'counsel-linux-app + '(("f" counsel-linux-app-action-file "run on a file") + ("d" counsel-linux-app-action-open-desktop "open desktop file"))) + +;;;###autoload +(defun counsel-linux-app (&optional arg) + "Launch a Linux desktop application, similar to Alt-. +When ARG is non-nil, ignore NoDisplay property in *.desktop files." + (interactive "P") + (ivy-read "Run application: " (counsel-linux-apps-list) + :predicate (unless arg (lambda (x) (get-text-property 0 'visible (car x)))) + :action #'counsel-linux-app-action-default + :caller 'counsel-linux-app)) + +;;;; `counsel-wmctrl' + +(defun counsel-wmctrl-action (x) + "Select the desktop window that corresponds to X." + (counsel--run "wmctrl" "-i" "-a" (cdr x))) + +(defvar counsel-wmctrl-ignore '("XdndCollectionWindowImp" + "unity-launcher" "unity-panel" "unity-dash" + "Hud" "Desktop") + "List of window titles to ignore for `counsel-wmctrl'.") + +(defun counsel--wmctrl-parse (s) + (when (string-match "\\`\\([0-9a-fx]+\\) +\\([-0-9]+\\) +\\(?:[0-9]+\\) +\\([^ ]+\\) \\(.+\\)$" s) + (let ((title (match-string 4 s)) + (id (match-string 1 s))) + (unless (member title counsel-wmctrl-ignore) + (cons title id))))) + +;;;###autoload +(defun counsel-wmctrl () + "Select a desktop window using wmctrl." + (interactive) + (let* ((cands1 (counsel--sl "wmctrl -l -p")) + (cands2 (delq nil (mapcar #'counsel--wmctrl-parse cands1)))) + (ivy-read "window: " cands2 + :action #'counsel-wmctrl-action + :caller 'counsel-wmctrl))) + +(defvar counsel--switch-buffer-temporary-buffers nil + "Internal.") + +(defvar counsel--switch-buffer-previous-buffers nil + "Internal.") + +(defun counsel--switch-buffer-unwind () + "Clear temporary file buffers and restore `buffer-list'. +The buffers are those opened during a session of `counsel-switch-buffer'." + (mapc #'kill-buffer counsel--switch-buffer-temporary-buffers) + (dolist (buf counsel--switch-buffer-previous-buffers) + (when (buffer-live-p buf) (bury-buffer buf))) + (setq counsel--switch-buffer-temporary-buffers ()) + (setq counsel--switch-buffer-previous-buffers ())) + +(defcustom counsel-switch-buffer-preview-virtual-buffers t + "When non-nil, `counsel-switch-buffer' will preview virtual buffers." + :type 'boolean) + +(defun counsel--switch-buffer-update-fn () + (unless counsel--switch-buffer-previous-buffers + (setq counsel--switch-buffer-previous-buffers (buffer-list))) + (let* ((virtual (assoc (ivy-state-current ivy-last) ivy--virtual-buffers))) + (when (member (ivy-state-current ivy-last) ivy-marked-candidates) + (setf (ivy-state-current ivy-last) + (substring (ivy-state-current ivy-last) (length ivy-mark-prefix)))) + (cond + ((get-buffer (ivy-state-current ivy-last)) + (let ((ivy-marked-candidates nil)) + (ivy-call))) + ((and counsel-switch-buffer-preview-virtual-buffers virtual (file-exists-p (cdr virtual))) + (let ((buf (ignore-errors + ;; may not open due to `large-file-warning-threshold' etc. + (find-file-noselect (cdr virtual))))) + (if buf + (progn + (push buf counsel--switch-buffer-temporary-buffers) + (ivy-call)) + ;; clean up the minibuffer so that there's no delay before + ;; the Ivy candidates are displayed once again + (message "")))) + (t + (with-ivy-window + (switch-to-buffer (ivy-state-buffer ivy-last))))))) + +;;;###autoload +(defun counsel-switch-buffer () + "Switch to another buffer. +Display a preview of the selected ivy completion candidate buffer +in the current window." + (interactive) + (let ((ivy-update-fns-alist + '((ivy-switch-buffer . counsel--switch-buffer-update-fn))) + (ivy-unwind-fns-alist + '((ivy-switch-buffer . counsel--switch-buffer-unwind)))) + (ivy-switch-buffer))) + +;;;###autoload +(defun counsel-switch-buffer-other-window () + "Switch to another buffer in another window. +Display a preview of the selected ivy completion candidate buffer +in the current window." + (interactive) + (let ((ivy-update-fns-alist + '((ivy-switch-buffer-other-window . counsel--switch-buffer-update-fn))) + (ivy-unwind-fns-alist + '((ivy-switch-buffer-other-window . counsel--switch-buffer-unwind)))) + (ivy-switch-buffer-other-window))) + +(defun counsel-open-buffer-file-externally (buffer) + "Open the file associated with BUFFER with an external program." + (when (zerop (length buffer)) + (user-error "Can't open that")) + (let* ((virtual (assoc buffer ivy--virtual-buffers)) + (filename (if virtual + (cdr virtual) + (buffer-file-name (get-buffer buffer))))) + (unless filename + (user-error "Can't open `%s' externally" buffer)) + (counsel-locate-action-extern (expand-file-name filename)))) + +(ivy-add-actions + 'ivy-switch-buffer + '(("x" counsel-open-buffer-file-externally "open externally"))) + +(ivy-set-actions + 'counsel-switch-buffer + '(("x" counsel-open-buffer-file-externally "open externally") + ("j" ivy--switch-buffer-other-window-action "other window"))) + +;;;; `counsel-compile' + +(defvar counsel-compile-history nil + "History for `counsel-compile'. + +This is a list of strings with additional properties which allow +the history to be filtered depending on the context of the call. +The properties include: + +`srcdir' + the root directory of the source code +`blddir' + the root directory of the build (in or outside the `srcdir') +`bldenv' + the build environment as passed to `compilation-environment' +`recursive' + the completion should be run again in `blddir' of this result +`cmd' + if set, pass only the substring with this property to `compile' + +This variable is suitable for addition to +`savehist-additional-variables'.") + +(defvar counsel-compile-root-functions + '(counsel--projectile-root + counsel--project-current + counsel--configure-root + counsel--git-root + counsel--dir-locals-root) + "Special hook to find the project root for compile commands. +Each function on this hook is called in turn with no arguments +and should return either a directory, or nil if no root was +found.") + +(defun counsel--compile-root () + "Return root of current project or signal an error on failure. +The root is determined by `counsel-compile-root-functions'." + (or (run-hook-with-args-until-success 'counsel-compile-root-functions) + (error "Couldn't find project root"))) + +(defun counsel--projectile-root () + "Return root of current projectile project or nil on failure. +Use `projectile-project-root' to determine the root." + (and (fboundp 'projectile-project-root) + (projectile-project-root))) + +(defun counsel--project-current () + "Return root of current project or nil on failure. +Use `project-current' to determine the root." + (let ((proj (and (fboundp 'project-current) + (project-current)))) + (cond ((not proj) nil) + ((fboundp 'project-root) + (project-root proj)) + ((fboundp 'project-roots) + (car (project-roots proj)))))) + +(defun counsel--configure-root () + "Return root of current project or nil on failure. +Use the presence of a \"configure\" file to determine the root." + (counsel--dominating-file "configure")) + +(defun counsel--git-root () + "Return root of current project or nil on failure. +Use the presence of a \".git\" file to determine the root." + (counsel--dominating-file ".git")) + +(defun counsel--dir-locals-root () + "Return root of current project or nil on failure. +Use the presence of a `dir-locals-file' to determine the root." + (counsel--dominating-file dir-locals-file)) + +(defvar counsel-compile-local-builds + '(counsel-compile-get-filtered-history + counsel-compile-get-build-directories + counsel-compile-get-make-invocation + counsel-compile-get-make-help-invocations) + "Additional compile invocations to feed into `counsel-compile'. + +This can either be a list of compile invocation strings or +functions that will provide such a list. You should customize +this if you want to provide specific non-standard build types to +`counsel-compile'. The default helpers are set up to handle +common build environments.") + +(defcustom counsel-compile-make-args "-k" + "Additional arguments for make. +You may, for example, want to add \"-jN\" for the number of cores +N in your system." + :type 'string) + +(defcustom counsel-compile-env nil + "List of environment variables for compilation to inherit. +Each element should be a string of the form ENVVARNAME=VALUE. This +list is passed to `compilation-environment'." + :type '(repeat (string :tag "ENVVARNAME=VALUE"))) + +(defvar counsel-compile-env-history nil + "History for `counsel-compile-env'.") + +(defvar counsel-compile-env-pattern + "[_[:digit:][:upper:]]+=[/[:alnum:]]*" + "Pattern to match valid environment variables.") + +(defcustom counsel-compile-make-pattern "\\`\\(?:GNUm\\|[Mm]\\)akefile\\'" + "Regexp for matching the names of Makefiles." + :type 'regexp) + +(defcustom counsel-compile-build-directories + '("build" "builds" "bld" ".build") + "List of potential build subdirectory names to check for." + :type '(repeat directory)) + +(defvar counsel-compile-phony-pattern "^\\.PHONY:[\t ]+\\(.+\\)$" + "Regexp for extracting phony targets from Makefiles.") + +(defvar counsel-compile-help-pattern + "\\(?:^\\(\\*\\)?[[:space:]]+\\([^[:space:]]+\\)[[:space:]]+-\\)" + "Regexp for extracting help targets from a make help call.") + +;; This is loosely based on the Bash Make completion code which +;; relies on GNUMake having the following return codes: +;; 0 = no-rebuild, -q & 1 needs rebuild, 2 error +(defun counsel-compile--probe-make-targets (dir) + "Return a list of Make targets for DIR. + +Return a single blank target (so we invoke the default target) +if Make exits with an error. This might happen because some sort +of configuration needs to be done first or the source tree is +pristine and being used for multiple build trees." + (with-temp-buffer + (let* ((default-directory dir) + (res (call-process "make" nil t nil "-nqp")) + targets) + (if (or (not (numberp res)) (> res 1)) + (list "") + (goto-char (point-min)) + (while (re-search-forward counsel-compile-phony-pattern nil t) + (push (split-string (match-string-no-properties 1)) targets)) + (sort (apply #'nconc targets) #'string-lessp))))) + +(defun counsel-compile--pretty-propertize (leader text face) + "Return a pretty string of the form \" LEADER TEXT\". +LEADER is propertized with a warning face and the remaining +text with FACE." + (concat (propertize (concat " " leader " ") + 'face + 'font-lock-warning-face) + (propertize text 'face face))) + +(defun counsel--compile-get-make-targets (probe-fn srcdir &optional blddir) + "Return propertized make targets returned by PROBE-FN in SRCDIR. + +The optional BLDDIR allows for handling build directories. We +search the Makefile for a list of phony targets which are +generally the top level targets a Make system provides. The +resulting strings are tagged with properties that +`counsel-compile-history' can use for filtering results." + (let ((fmt (format (propertize "make %s %%s" 'cmd t) + counsel-compile-make-args)) + (suffix (and blddir + (counsel-compile--pretty-propertize "in" blddir + 'dired-directory))) + (build-env (and counsel-compile-env + (counsel-compile--pretty-propertize + "with" + (mapconcat #'identity counsel-compile-env " ") + 'font-lock-variable-name-face))) + (props `(srcdir ,srcdir blddir ,blddir bldenv ,counsel-compile-env))) + (mapcar (lambda (target) + (setq target (concat (format fmt target) suffix build-env)) + (add-text-properties 0 (length target) props target) + target) + (funcall probe-fn (or blddir srcdir))))) + +(defun counsel-compile-get-make-invocation (&optional blddir) + "Have a look in the root directory for any build control files. + +The optional BLDDIR is useful for other helpers that have found +sub-directories that builds may be invoked in." + (let ((srcdir (counsel--compile-root))) + (when (directory-files (or blddir srcdir) nil + counsel-compile-make-pattern t) + (counsel--compile-get-make-targets + #'counsel-compile--probe-make-targets srcdir blddir)))) + +(defun counsel-compile--probe-make-help (dir) + "Return a list of Make targets based on help for DIR. + +It is quite common for a \"make help\" invocation to return a +human readable list of targets. Often common targets are marked +with a leading asterisk. The exact search pattern is controlled +by `counsel-compile-help-pattern'." + (let ((default-directory dir) + primary-targets targets) + ;; Only proceed if the help target exists. + (when (eql 1 (apply #'call-process "make" nil nil nil "-q" "help" + counsel-compile-env)) + (with-temp-buffer + (when (eql 0 (apply #'call-process "make" nil t nil "help" + counsel-compile-env)) + (goto-char (point-min)) + (while (re-search-forward counsel-compile-help-pattern nil t) + (push (match-string 2) + (if (match-beginning 1) primary-targets targets))) + (nconc (sort primary-targets #'string-lessp) + (sort targets #'string-lessp))))))) + +(defun counsel-compile-get-make-help-invocations (&optional blddir) + "Query the root directory for makefiles with help output. + +The optional BLDDIR is useful for other helpers that have found +sub-directories that builds may be invoked in." + (let ((srcdir (counsel--compile-root))) + (when (directory-files (or blddir srcdir) nil + counsel-compile-make-pattern t) + (counsel--compile-get-make-targets + #'counsel-compile--probe-make-help srcdir blddir)))) + +(defun counsel--find-build-subdir (srcdir) + "Return builds subdirectory of SRCDIR, if one exists." + (cl-some (lambda (dir) + (setq dir (expand-file-name dir srcdir)) + (and (file-directory-p dir) dir)) + counsel-compile-build-directories)) + +(defun counsel--get-build-subdirs (blddir) + "Return all subdirs under BLDDIR sorted by modification time. +If there are non-directory files in BLDDIR, include BLDDIR in the +list as it may also be a build directory." + (let* ((files (directory-files-and-attributes + blddir t directory-files-no-dot-files-regexp t)) + (total (length files)) + (dirs (cl-delete-if-not + (lambda (entry) + (let ((dir (nth 1 entry))) + (and dir (or (eq dir t) + ;; Symlink. + (file-directory-p (nth 0 entry)))))) + files))) + ;; Any non-dir files? + (when (< (length dirs) total) + (push (cons blddir (file-attributes blddir)) dirs)) + (mapcar #'car (sort dirs (lambda (x y) + (time-less-p (nth 6 y) (nth 6 x))))))) + +(defun counsel-compile-get-build-directories (&optional dir) + "Return a list of potential build directories." + (let* ((srcdir (or dir (counsel--compile-root))) + (blddir (counsel--find-build-subdir srcdir)) + (props `(srcdir ,srcdir recursive t)) + (fmt (concat (propertize "Select build in " + 'face 'font-lock-warning-face) + (propertize "%s" 'face 'dired-directory)))) + (mapcar (lambda (subdir) + (let ((s (format fmt subdir))) + (add-text-properties 0 (length s) `(blddir ,subdir ,@props) s) + s)) + (and blddir (counsel--get-build-subdirs blddir))))) + +;; This is a workaround for the fact there is no concept of "project" +;; local variables (as opposed to for example buffer-local). So we +;; store all our history in a global list filter out the results we +;; don't want. +(defun counsel-compile-get-filtered-history (&optional dir) + "Return a compile history relevant to current project." + (let ((root (or dir (counsel--compile-root))) + history) + (dolist (item counsel-compile-history) + (let ((srcdir (get-text-property 0 'srcdir item)) + (blddir (get-text-property 0 'blddir item))) + (when (or (and srcdir (file-in-directory-p srcdir root)) + (and blddir (file-in-directory-p blddir root))) + (push item history)))) + (nreverse history))) + +(defun counsel--get-compile-candidates (&optional dir) + "Return the list of compile commands. +This is determined by `counsel-compile-local-builds', which see." + (let (cands) + (dolist (cmds counsel-compile-local-builds) + (when (functionp cmds) + (setq cmds (funcall cmds dir))) + (when cmds + (push (if (listp cmds) cmds (list cmds)) cands))) + (apply #'append (nreverse cands)))) + +;; This is a workaround to ensure we tag all the relevant metadata in +;; our compile history. This also allows M-x compile to do fancy +;; things like infer `default-directory' from 'cd's in the string. +(defun counsel-compile--update-history (_proc) + "Update `counsel-compile-history' from the compilation state." + (defvar compilation-arguments) + (defvar compilation-environment) + (let* ((srcdir (counsel--compile-root)) + (blddir default-directory) + (bldenv compilation-environment) + (cmd (concat + (propertize (car compilation-arguments) 'cmd t) + (unless (file-equal-p blddir srcdir) + (counsel-compile--pretty-propertize "in" blddir + 'dired-directory)) + (when bldenv + (counsel-compile--pretty-propertize "with" + (mapconcat #'identity bldenv " ") + 'font-lock-variable-name-face))))) + (add-text-properties 0 (length cmd) + `(srcdir ,srcdir blddir ,blddir bldenv ,bldenv) cmd) + (add-to-history 'counsel-compile-history cmd))) + +(defvar counsel-compile--current-build-dir nil + "Tracks the last directory `counsel-compile' was called with. + +This state allows us to set it correctly if the user has manually +edited the command, thus losing our embedded state.") + +(defun counsel-compile--action (cmd) + "Process CMD to call `compile'. + +If CMD has the `recursive' property set we call `counsel-compile' +again to further refine the compile options in the directory +specified by the `blddir' property." + (defvar compilation-environment) + (let ((blddir (get-text-property 0 'blddir cmd)) + (bldenv (get-text-property 0 'bldenv cmd))) + (if (get-text-property 0 'recursive cmd) + (counsel-compile blddir) + (when (get-char-property 0 'cmd cmd) + (setq cmd (substring-no-properties + cmd 0 (next-single-property-change 0 'cmd cmd)))) + (let ((default-directory (or blddir + counsel-compile--current-build-dir + default-directory)) + (compilation-environment bldenv)) + ;; No need to specify `:history' because of this hook. + (add-hook 'compilation-start-hook #'counsel-compile--update-history) + (unwind-protect + (compile cmd) + (remove-hook 'compilation-start-hook #'counsel-compile--update-history)))))) + +(defun counsel-compile-edit-command () + "Insert current compile command into the minibuffer for editing. + +This mirrors the behavior of `ivy-insert-current' but with specific +handling for the `counsel-compile' metadata." + (interactive) + (delete-minibuffer-contents) + (let* ((cmd (ivy-state-current ivy-last)) + (blddir (get-text-property 0 'blddir cmd))) + (when blddir + (setq counsel-compile--current-build-dir blddir)) + (insert (substring-no-properties + cmd 0 (and (get-text-property 0 'cmd cmd) + (next-single-property-change 0 'cmd cmd)))))) + +;; Currently the only thing we do is override ivy's default insert +;; operation which doesn't include the metadata we want. +(defvar counsel-compile-map + (let ((map (make-sparse-keymap))) + (define-key map `[remap ,#'ivy-insert-current] + #'counsel-compile-edit-command) + map) + "Additional ivy keybindings during command selection.") + +;;;###autoload +(defun counsel-compile (&optional dir) + "Call `compile' completing with smart suggestions, optionally for DIR. + +Additional actions: + +\\{counsel-compile-map}" + (interactive) + (require 'compile) + (require 'dired) ;; For face `dired-directory'. + (setq counsel-compile--current-build-dir (or dir + (counsel--compile-root) + default-directory)) + (ivy-read "Compile command: " + (delete-dups (counsel--get-compile-candidates dir)) + :action #'counsel-compile--action + :keymap counsel-compile-map + :caller 'counsel-compile)) + +(ivy-add-actions + 'counsel-compile + '(("d" counsel-compile-forget-command "delete"))) + +(defun counsel-compile-forget-command (cmd) + "Delete CMD from `counsel-compile-history'." + (setq counsel-compile-history + (delete cmd counsel-compile-history))) + +(defun counsel-compile-env--format-hint (cands) + "Return a formatter for compile-env CANDS." + (let ((rmstr + (propertize "remove" 'face 'font-lock-warning-face)) + (addstr + (propertize "add" 'face 'font-lock-variable-name-face))) + (ivy--format-function-generic + (lambda (selected) + (format "%s %s" + (if (member selected counsel-compile-env) rmstr addstr) + selected)) + #'identity + cands + "\n"))) + +(defun counsel-compile-env--update (var) + "Update `counsel-compile-env' either adding or removing VAR." + (cond ((member var counsel-compile-env) + (setq counsel-compile-env (delete var counsel-compile-env))) + ((string-match-p counsel-compile-env-pattern var) + (push var counsel-compile-env)) + (t (user-error "Ignoring malformed variable: '%s'" var)))) + +;;;###autoload +(defun counsel-compile-env () + "Update `counsel-compile-env' interactively." + (interactive) + (ivy-read "Compile environment variable: " + (delete-dups (append + counsel-compile-env counsel-compile-env-history)) + :action #'counsel-compile-env--update + :predicate (lambda (cand) + (string-match-p counsel-compile-env-pattern + cand)) + :history 'counsel-compile-env-history + :caller 'counsel-compile-env)) + +(ivy-configure 'counsel-compile-env + :format-fn #'counsel-compile-env--format-hint) + +;;;; `counsel-search' + +(defcustom counsel-search-engine 'ddg + "The search engine choice in `counsel-search-engines-alist'." + :type '(choice + (const :tag "DuckDuckGo" ddg) + (const :tag "Google" google))) + +(defcustom counsel-search-engines-alist + '((ddg + "https://duckduckgo.com/ac/" + "https://duckduckgo.com/html/?q=" + counsel--search-request-data-ddg) + (google + "https://suggestqueries.google.com/complete/search" + "https://www.google.com/search?q=" + counsel--search-request-data-google)) + "List of search engine parameters for `counsel-search'. +Each element is of the form (SYMBOL SUGGEST BROWSE EXTRACT), where: +SYMBOL identifies the search engine, as per `counsel-search-engine'. +SUGGEST is the URL to query for suggestions. +BROWSE is the URL prefix for visiting the selected result. +EXTRACT is a function that takes the object parsed from the SUGGEST + endpoint and transforms it into a set of Ivy candidates." + :package-version '(counsel . "0.15.1") + :type '(alist :key-type symbol :value-type (list string string function))) + +(defun counsel--search-request-data-google (data) + "Extract Google suggestions from parsed JSON DATA. +Expects input of the form [\"a\" [\"ab\" \"ac\"] ...]." + (append (aref data 1) ())) + +(defun counsel--search-request-data-ddg (data) + "Extract DuckDuckGo suggestions from parsed JSON DATA. +Expects input of the form [((phrase . \"ab\")) ...]." + (mapcar #'cdar data)) + +(defvar counsel--native-json) +(put 'counsel--native-json 'variable-documentation + "Non-nil if Emacs supports JSON natively, or void.") + +(defun counsel--search-update (extract str type) + "Call EXTRACT on JSON STR of Content-TYPE." + (unless (fboundp 'mail-header-parse-content-type) + (require 'mail-parse)) + (declare-function json-parse-string "json.c") + (declare-function json-read-from-string "json") + (declare-function mail-content-type-get "mail-parse") + (declare-function mail-header-parse-content-type "mail-parse") + (let* ((ct (and type (mail-header-parse-content-type type))) + (coding (coding-system-from-name (mail-content-type-get ct 'charset)))) + (when coding + (setq str (decode-coding-string str coding t)))) + (let ((obj (if counsel--native-json + (json-parse-string str :object-type 'alist) + (defvar json-array-type) + (defvar json-object-type) + (let ((json-array-type 'vector) + (json-object-type 'alist)) + (json-read-from-string str))))) + (ivy-update-candidates (funcall extract obj)))) + +(defun counsel--search-plz (url extract) + "Fetch URL with `plz' and EXTRACT its JSON payload." + (declare-function plz "ext:plz") + (declare-function plz-response-body "ext:plz") + (declare-function plz-response-headers "ext:plz") + ;; Doesn't handle Content-Type, so defer decoding+parsing until :then. + ;; (See URL `https://github.com/alphapapa/plz.el/pull/66'.) + ;; Ask for a `plz-response' object because it already contains the parsed + ;; headers (though just widening the response buffer could be quicker). + (plz 'get url :as 'response :decode nil :noquery t + :then (lambda (response) + (let* ((heads (plz-response-headers response)) + (body (plz-response-body response)) + (ct (cdr (assq 'content-type heads)))) + (counsel--search-update extract body ct))))) + +(defun counsel--search-request (url extract) + "Fetch URL with `request' and EXTRACT its JSON payload." + (declare-function request "ext:request") + (declare-function request-response-header "ext:request") + ;; Doesn't handle Content-Type (expects coding system a priori), + ;; so defer decoding+parsing until :success. + (request url :type "GET" + :success (cl-function + (lambda (&key data response &allow-other-keys) + (let ((ct (request-response-header response "content-type"))) + (counsel--search-update extract data ct)))))) + +(defvar counsel--search-backend) +(put 'counsel--search-backend 'variable-documentation + "Feature symbol indicating available HTTP library, or void. +Valid values are the keys of `counsel--search-backends'.") + +(defvar counsel--search-backends + `((plz ,#'counsel--search-plz) + (request ,#'counsel--search-request)) + "List of (BACKEND GETTER) for `counsel-search'. +BACKEND is a feature symbol like `counsel--search-backend'. +GETTER is a function taking a URL and an EXTRACT function as in + `counsel-search-engines-alist'.") + +(defun counsel-search-function (input) + "Create a request to a search engine with INPUT. +Return 0 tells `ivy--exhibit' not to update the minibuffer. +We update it in the callback with `ivy-update-candidates'." + (or + (ivy-more-chars) + (let* ((backend (assq counsel--search-backend counsel--search-backends)) + (engine (assq counsel-search-engine counsel-search-engines-alist)) + (suggest (nth 1 engine)) + (extract (nth 3 engine)) + (url (concat suggest (if (ivy--string-search "?" suggest) "&" "?") + ;; FIXME: `client' needed only for `google'? + (url-build-query-string `(("client" "firefox") + ("q" ,input)))))) + ;; Do we need to cancel requests already in flight? + (funcall (nth 1 backend) url extract) + 0))) + +(defun counsel-search-action (candidate) + "Browse the search results for `counsel-search' CANDIDATE." + (let ((engine (assq counsel-search-engine counsel-search-engines-alist))) + (browse-url (concat (nth 2 engine) (url-hexify-string candidate))))) + +(defun counsel-search () + "Ivy interface for querying a search engine. +Dynamically displays search suggestions for the current input. +The user options `counsel-search-engine' and +`counsel-search-engines-alist' determine the engine." + (interactive) + (unless (boundp 'counsel--search-backend) + (setq counsel--search-backend + ;; `plz' is on GNU ELPA; `request' on NonGNU ELPA. + (or (require 'plz nil t) + (require 'request nil t) + (user-error + "Required package `plz' (or `request') not installed")))) + ;; - Emacs 27: optional native JSON support. + ;; - Emacs 28: `json-available-p'. + ;; - Emacs 30: unconditional native JSON support. + ;; That means the following sets `counsel--native-json' to nil even for + ;; Emacs 27 with native JSON support, in the interest of simplicity. + (or (boundp 'counsel--native-json) + (setq counsel--native-json + (and (fboundp 'json-available-p) + (json-available-p))) + (require 'json)) + (ivy-read "search: " #'counsel-search-function + :action #'counsel-search-action + :dynamic-collection t + :caller 'counsel-search)) + +(define-obsolete-function-alias 'counsel-google + #'counsel-search "0.13.2 (2019-10-17)") + +;;;; `counsel-compilation-errors' + +(declare-function compilation--message->loc "compile" t t) +(declare-function compilation-buffer-p "compile") +(declare-function compilation-next-single-property-change "compile") +(declare-function compile-goto-error "compile") + +(defun counsel--compilation-errors-buffer (buf) + (with-current-buffer buf + (let ((res nil) + (pt (point-min))) + (save-excursion + (while (setq pt (compilation-next-single-property-change + pt 'compilation-message)) + (let ((loc (get-text-property pt 'compilation-message))) + (when (and loc (setq loc (compilation--message->loc loc))) + (goto-char pt) + (push + (propertize + (buffer-substring-no-properties pt (line-end-position)) + 'pt pt + 'buffer buf) + res))))) + (nreverse res)))) + +(defun counsel-compilation-errors-cands () + (cl-loop + for buf in (buffer-list) + when (compilation-buffer-p buf) + nconc (counsel--compilation-errors-buffer buf))) + +(defun counsel-compilation-errors-action (x) + (pop-to-buffer (get-text-property 0 'buffer x)) + (goto-char (get-text-property 0 'pt x)) + (compile-goto-error)) + +;;;###autoload +(defun counsel-compilation-errors () + "Compilation errors." + (interactive) + (require 'compile) + (ivy-read "compilation errors: " (counsel-compilation-errors-cands) + :require-match t + :action #'counsel-compilation-errors-action + :history 'counsel-compilation-errors-history)) + +;;;; `counsel-flycheck' + +(defvar flycheck-current-errors) +(declare-function flycheck-error-filename "ext:flycheck") +(declare-function flycheck-error-line "ext:flycheck") +(declare-function flycheck-error-message "ext:flycheck") +(declare-function flycheck-jump-to-error "ext:flycheck") + +(defun counsel-flycheck-errors-cands () + (mapcar + (lambda (err) + (propertize + (format "%s:%d:%s" + (file-name-base (flycheck-error-filename err)) + (flycheck-error-line err) + (flycheck-error-message err)) 'error err)) + flycheck-current-errors)) + +(defun counsel-flycheck-occur (cands) + "Generate a custom occur buffer for `counsel-flycheck'." + (unless (eq major-mode 'ivy-occur-grep-mode) + (ivy-occur-grep-mode) + (setq default-directory (ivy-state-directory ivy-last))) + (swiper--occur-insert-lines + (mapcar + (lambda (cand) + (let ((err (get-text-property 0 'error cand))) + (propertize + (format + "%s:%d:%s" + (flycheck-error-filename err) + (flycheck-error-line err) + cand) + 'error err))) + cands))) + +(defun counsel-flycheck-errors-action (err) + (flycheck-jump-to-error (get-text-property 0 'error err))) + +(ivy-configure 'counsel-flycheck + :occur #'counsel-flycheck-occur) + +;;;###autoload +(defun counsel-flycheck () + "Flycheck errors." + (interactive) + (require 'flycheck) + (ivy-read "flycheck errors: " (counsel-flycheck-errors-cands) + :require-match t + :action #'counsel-flycheck-errors-action + :history 'counsel-flycheck-errors-history)) + +;;; `counsel-mode' + +(defvar counsel-mode-map + (let ((map (make-sparse-keymap))) + (define-key map `[remap ,#'execute-extended-command] #'counsel-M-x) + (define-key map `[remap ,#'describe-bindings] #'counsel-descbinds) + (define-key map `[remap ,#'describe-function] #'counsel-describe-function) + (define-key map `[remap ,#'describe-variable] #'counsel-describe-variable) + (define-key map [remap describe-symbol] #'counsel-describe-symbol) + (define-key map `[remap ,#'apropos-command] #'counsel-apropos) + (define-key map `[remap ,#'describe-face] #'counsel-describe-face) + (define-key map `[remap ,#'list-faces-display] #'counsel-faces) + (define-key map `[remap ,#'find-file] #'counsel-find-file) + (define-key map `[remap ,#'find-library] #'counsel-find-library) + (define-key map `[remap ,#'imenu] #'counsel-imenu) + (define-key map `[remap ,#'load-library] #'counsel-load-library) + (define-key map `[remap ,#'load-theme] #'counsel-load-theme) + (define-key map `[remap ,#'yank-pop] #'counsel-yank-pop) + (define-key map `[remap ,#'info-lookup-symbol] #'counsel-info-lookup-symbol) + (define-key map `[remap ,#'pop-to-mark-command] #'counsel-mark-ring) + (define-key map [remap geiser-doc-look-up-manual] + #'counsel-geiser-doc-look-up-manual) + (define-key map `[remap ,#'bookmark-jump] #'counsel-bookmark) + map) + "Keymap for `counsel-mode'. +Remaps built-in and external functions to Counsel replacements.") + +(defcustom counsel-mode-override-describe-bindings nil + "Whether to override `describe-bindings' when `counsel-mode' is active." + :type 'boolean) + +;;;###autoload +(define-minor-mode counsel-mode + "Toggle Counsel mode on or off. +Turn Counsel mode on if ARG is positive, off otherwise. Counsel +mode remaps built-in emacs functions that have counsel +replacements. + +Local bindings (`counsel-mode-map'): +\\{counsel-mode-map}" + :global t + :keymap counsel-mode-map + :lighter " counsel" + (if counsel-mode + (progn + (when counsel-mode-override-describe-bindings + (advice-add #'describe-bindings :override #'counsel-descbinds)) + (define-key minibuffer-local-map (kbd "C-r") + #'counsel-minibuffer-history)) + (advice-remove #'describe-bindings #'counsel-descbinds))) + +(provide 'counsel) + +;;; counsel.el ends here diff --git a/.emacs.d/lisp/dash.el b/.emacs.d/lisp/dash.el new file mode 100644 index 0000000..f7c12b0 --- /dev/null +++ b/.emacs.d/lisp/dash.el @@ -0,0 +1,4164 @@ +;;; dash.el --- A modern list library for Emacs -*- lexical-binding: t -*- + +;; Copyright (C) 2012-2025 Free Software Foundation, Inc. + +;; Author: Magnar Sveen +;; Maintainer: Basil L. Contovounesios +;; Version: 2.20.0 +;; Package-Requires: ((emacs "24")) +;; Keywords: extensions, lisp +;; URL: https://github.com/magnars/dash.el + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; A modern list API for Emacs. +;; +;; See its overview at https://github.com/magnars/dash.el#functions. + +;;; Code: + +(eval-when-compile + (unless (fboundp 'static-if) + (defmacro static-if (condition then-form &rest else-forms) + "Expand to THEN-FORM or ELSE-FORMS based on compile-time CONDITION. +Polyfill for Emacs 30 `static-if'." + (declare (debug (sexp sexp &rest sexp)) (indent 2)) + (if (eval condition lexical-binding) + then-form + (cons 'progn else-forms)))) + + ;; TODO: Emacs 24.3 first introduced `gv', so remove this and all + ;; calls to `defsetf' when support for earlier versions is dropped. + (unless (fboundp 'gv-define-setter) + (require 'cl)) + + ;; - 24.3 started complaining about unknown `declare' props. + ;; - 25 introduced `pure' and `side-effect-free'. + ;; - 30 introduced `important-return-value'. + (when (boundp 'defun-declarations-alist) + (dolist (prop '(important-return-value pure side-effect-free)) + (unless (assq prop defun-declarations-alist) + (push (list prop #'ignore) defun-declarations-alist))))) + +(defgroup dash () + "Customize group for Dash, a modern list library." + :group 'extensions + :group 'lisp + :prefix "dash-") + +(defmacro !cons (car cdr) + "Destructive: Set CDR to the cons of CAR and CDR." + (declare (debug (form symbolp))) + `(setq ,cdr (cons ,car ,cdr))) + +(defmacro !cdr (list) + "Destructive: Set LIST to the cdr of LIST." + (declare (debug (symbolp))) + `(setq ,list (cdr ,list))) + +(defmacro --each (list &rest body) + "Evaluate BODY for each element of LIST and return nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating BODY. +This is the anaphoric counterpart to `-each'." + (declare (debug (form body)) (indent 1)) + (let ((l (make-symbol "list")) + (i (make-symbol "i"))) + `(let ((,l ,list) + (,i 0)) + (while ,l + (let ((it (pop ,l)) (it-index ,i)) + (ignore it it-index) + ,@body) + (setq ,i (1+ ,i)))))) + +(defun -each (list fn) + "Call FN on each element of LIST. +Return nil; this function is intended for side effects. + +Its anaphoric counterpart is `--each'. + +For access to the current element's index in LIST, see +`-each-indexed'." + (declare (indent 1)) + (ignore (mapc fn list))) + +(defalias '--each-indexed '--each) + +(defun -each-indexed (list fn) + "Call FN on each index and element of LIST. +For each ITEM at INDEX in LIST, call (funcall FN INDEX ITEM). +Return nil; this function is intended for side effects. + +See also: `-map-indexed'." + (declare (indent 1)) + (--each list (funcall fn it-index it))) + +(defmacro --each-while (list pred &rest body) + "Evaluate BODY for each item in LIST, while PRED evaluates to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating PRED or BODY. Once +an element is reached for which PRED evaluates to nil, no further +BODY is evaluated. The return value is always nil. +This is the anaphoric counterpart to `-each-while'." + (declare (debug (form form body)) (indent 2)) + (let ((l (make-symbol "list")) + (i (make-symbol "i")) + (elt (make-symbol "elt"))) + `(let ((,l ,list) + (,i 0) + ,elt) + (while (when ,l + (setq ,elt (car-safe ,l)) + (let ((it ,elt) (it-index ,i)) + (ignore it it-index) + ,pred)) + (let ((it ,elt) (it-index ,i)) + (ignore it it-index) + ,@body) + (setq ,i (1+ ,i) ,l (cdr ,l)))))) + +(defun -each-while (list pred fn) + "Call FN on each ITEM in LIST, while (PRED ITEM) is non-nil. +Once an ITEM is reached for which PRED returns nil, FN is no +longer called. Return nil; this function is intended for side +effects. + +Its anaphoric counterpart is `--each-while'." + (declare (indent 2)) + (--each-while list (funcall pred it) (funcall fn it))) + +(defmacro --each-r (list &rest body) + "Evaluate BODY for each element of LIST in reversed order. +Each element of LIST in turn, starting at its end, is bound to +`it' and its index within LIST to `it-index' before evaluating +BODY. The return value is always nil. +This is the anaphoric counterpart to `-each-r'." + (declare (debug (form body)) (indent 1)) + (let ((v (make-symbol "vector")) + (i (make-symbol "i"))) + ;; Implementation note: building a vector is considerably faster + ;; than building a reversed list (vector takes less memory, so + ;; there is less GC), plus `length' comes naturally. In-place + ;; `nreverse' would be faster still, but BODY would be able to see + ;; that, even if the modification was undone before we return. + `(let* ((,v (vconcat ,list)) + (,i (length ,v)) + it it-index) + (ignore it it-index) + (while (> ,i 0) + (setq ,i (1- ,i) it-index ,i it (aref ,v ,i)) + ,@body)))) + +(defun -each-r (list fn) + "Call FN on each element of LIST in reversed order. +Return nil; this function is intended for side effects. + +Its anaphoric counterpart is `--each-r'." + (--each-r list (funcall fn it))) + +(defmacro --each-r-while (list pred &rest body) + "Eval BODY for each item in reversed LIST, while PRED evals to non-nil. +Each element of LIST in turn, starting at its end, is bound to +`it' and its index within LIST to `it-index' before evaluating +PRED or BODY. Once an element is reached for which PRED +evaluates to nil, no further BODY is evaluated. The return value +is always nil. +This is the anaphoric counterpart to `-each-r-while'." + (declare (debug (form form body)) (indent 2)) + (let ((v (make-symbol "vector")) + (i (make-symbol "i")) + (elt (make-symbol "elt"))) + `(let* ((,v (vconcat ,list)) + (,i (length ,v)) + ,elt it it-index) + (ignore it it-index) + (while (when (> ,i 0) + (setq ,i (1- ,i) it-index ,i) + (setq ,elt (aref ,v ,i) it ,elt) + ,pred) + (setq it-index ,i it ,elt) + ,@body)))) + +(defun -each-r-while (list pred fn) + "Call FN on each ITEM in reversed LIST, while (PRED ITEM) is non-nil. +Once an ITEM is reached for which PRED returns nil, FN is no +longer called. Return nil; this function is intended for side +effects. + +Its anaphoric counterpart is `--each-r-while'." + (--each-r-while list (funcall pred it) (funcall fn it))) + +(defmacro --dotimes (num &rest body) + "Evaluate BODY NUM times, presumably for side effects. +BODY is evaluated with the local variable `it' temporarily bound +to successive integers running from 0, inclusive, to NUM, +exclusive. BODY is not evaluated if NUM is less than 1. +This is the anaphoric counterpart to `-dotimes'." + (declare (debug (form body)) (indent 1)) + (let ((n (make-symbol "num")) + (i (make-symbol "i"))) + `(let ((,n ,num) + (,i 0) + it) + (ignore it) + (while (< ,i ,n) + (setq it ,i ,i (1+ ,i)) + ,@body)))) + +(defun -dotimes (num fn) + "Call FN NUM times, presumably for side effects. +FN is called with a single argument on successive integers +running from 0, inclusive, to NUM, exclusive. FN is not called +if NUM is less than 1. + +This function's anaphoric counterpart is `--dotimes'." + (declare (indent 1)) + (--dotimes num (funcall fn it))) + +(defun -map (fn list) + "Apply FN to each item in LIST and return the list of results. + +This function's anaphoric counterpart is `--map'." + (declare (important-return-value t)) + (mapcar fn list)) + +(defmacro --map (form list) + "Eval FORM for each item in LIST and return the list of results. +Each element of LIST in turn is bound to `it' before evaluating +FORM. +This is the anaphoric counterpart to `-map'." + (declare (debug (def-form form))) + `(mapcar (lambda (it) (ignore it) ,form) ,list)) + +(defmacro --reduce-from (form init list) + "Accumulate a value by evaluating FORM across LIST. +This macro is like `--each' (which see), but it additionally +provides an accumulator variable `acc' which it successively +binds to the result of evaluating FORM for the current LIST +element before processing the next element. For the first +element, `acc' is initialized with the result of evaluating INIT. +The return value is the resulting value of `acc'. If LIST is +empty, FORM is not evaluated, and the return value is the result +of INIT. +This is the anaphoric counterpart to `-reduce-from'." + (declare (debug (form form form))) + `(let ((acc ,init)) + (--each ,list (setq acc ,form)) + acc)) + +(defun -reduce-from (fn init list) + "Reduce the function FN across LIST, starting with INIT. +Return the result of applying FN to INIT and the first element of +LIST, then applying FN to that result and the second element, +etc. If LIST is empty, return INIT without calling FN. + +This function's anaphoric counterpart is `--reduce-from'. + +For other folds, see also `-reduce' and `-reduce-r'." + (declare (important-return-value t)) + (--reduce-from (funcall fn acc it) init list)) + +(defmacro --reduce (form list) + "Accumulate a value by evaluating FORM across LIST. +This macro is like `--reduce-from' (which see), except the first +element of LIST is taken as INIT. Thus if LIST contains a single +item, it is returned without evaluating FORM. If LIST is empty, +FORM is evaluated with `it' and `acc' bound to nil. +This is the anaphoric counterpart to `-reduce'." + (declare (debug (form form))) + (let ((lv (make-symbol "list-value"))) + `(let ((,lv ,list)) + (if ,lv + (--reduce-from ,form (car ,lv) (cdr ,lv)) + ;; Explicit nil binding pacifies lexical "variable left uninitialized" + ;; warning. See issue #377 and upstream https://bugs.gnu.org/47080. + (let ((acc nil) (it nil)) + (ignore acc it) + ,form))))) + +(defun -reduce (fn list) + "Reduce the function FN across LIST. +Return the result of applying FN to the first two elements of +LIST, then applying FN to that result and the third element, etc. +If LIST contains a single element, return it without calling FN. +If LIST is empty, return the result of calling FN with no +arguments. + +This function's anaphoric counterpart is `--reduce'. + +For other folds, see also `-reduce-from' and `-reduce-r'." + (declare (important-return-value t)) + (if list + (-reduce-from fn (car list) (cdr list)) + (funcall fn))) + +(defmacro --reduce-r-from (form init list) + "Accumulate a value by evaluating FORM across LIST in reverse. +This macro is like `--reduce-from', except it starts from the end +of LIST. +This is the anaphoric counterpart to `-reduce-r-from'." + (declare (debug (form form form))) + `(let ((acc ,init)) + (--each-r ,list (setq acc ,form)) + acc)) + +(defun -reduce-r-from (fn init list) + "Reduce the function FN across LIST in reverse, starting with INIT. +Return the result of applying FN to the last element of LIST and +INIT, then applying FN to the second-to-last element and the +previous result of FN, etc. That is, the first argument of FN is +the current element, and its second argument the accumulated +value. If LIST is empty, return INIT without calling FN. + +This function is like `-reduce-from' but the operation associates +from the right rather than left. In other words, it starts from +the end of LIST and flips the arguments to FN. Conceptually, it +is like replacing the conses in LIST with applications of FN, and +its last link with INIT, and evaluating the resulting expression. + +This function's anaphoric counterpart is `--reduce-r-from'. + +For other folds, see also `-reduce-r' and `-reduce'." + (declare (important-return-value t)) + (--reduce-r-from (funcall fn it acc) init list)) + +(defmacro --reduce-r (form list) + "Accumulate a value by evaluating FORM across LIST in reverse order. +This macro is like `--reduce', except it starts from the end of +LIST. +This is the anaphoric counterpart to `-reduce-r'." + (declare (debug (form form))) + `(--reduce ,form (reverse ,list))) + +(defun -reduce-r (fn list) + "Reduce the function FN across LIST in reverse. +Return the result of applying FN to the last two elements of +LIST, then applying FN to the third-to-last element and the +previous result of FN, etc. That is, the first argument of FN is +the current element, and its second argument the accumulated +value. If LIST contains a single element, return it without +calling FN. If LIST is empty, return the result of calling FN +with no arguments. + +This function is like `-reduce' but the operation associates from +the right rather than left. In other words, it starts from the +end of LIST and flips the arguments to FN. Conceptually, it is +like replacing the conses in LIST with applications of FN, +ignoring its last link, and evaluating the resulting expression. + +This function's anaphoric counterpart is `--reduce-r'. + +For other folds, see also `-reduce-r-from' and `-reduce'." + (declare (important-return-value t)) + (if list + (--reduce-r (funcall fn it acc) list) + (funcall fn))) + +(defmacro --reductions-from (form init list) + "Return a list of FORM's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce-from' (which see) is called with the same +arguments. +This is the anaphoric counterpart to `-reductions-from'." + (declare (debug (form form form))) + `(nreverse + (--reduce-from (cons (let ((acc (car acc))) (ignore acc) ,form) acc) + (list ,init) + ,list))) + +(defun -reductions-from (fn init list) + "Return a list of FN's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce-from' (which see) is called with the same +arguments. + +This function's anaphoric counterpart is `--reductions-from'. + +For other folds, see also `-reductions' and `-reductions-r'." + (declare (important-return-value t)) + (--reductions-from (funcall fn acc it) init list)) + +(defmacro --reductions (form list) + "Return a list of FORM's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce' (which see) is called with the same arguments. +This is the anaphoric counterpart to `-reductions'." + (declare (debug (form form))) + (let ((lv (make-symbol "list-value"))) + `(let ((,lv ,list)) + (if ,lv + (--reductions-from ,form (car ,lv) (cdr ,lv)) + ;; Explicit nil binding pacifies lexical "variable left uninitialized" + ;; warning. See issue #377 and upstream https://bugs.gnu.org/47080. + (let ((acc nil) (it nil)) + (ignore acc it) + (list ,form)))))) + +(defun -reductions (fn list) + "Return a list of FN's intermediate reductions across LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce' (which see) is called with the same arguments. + +This function's anaphoric counterpart is `--reductions'. + +For other folds, see also `-reductions' and `-reductions-r'." + (declare (important-return-value t)) + (if list + (--reductions-from (funcall fn acc it) (car list) (cdr list)) + (list (funcall fn)))) + +(defmacro --reductions-r-from (form init list) + "Return a list of FORM's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce-r-from' (which see) is called with the same +arguments. +This is the anaphoric counterpart to `-reductions-r-from'." + (declare (debug (form form form))) + `(--reduce-r-from (cons (let ((acc (car acc))) (ignore acc) ,form) acc) + (list ,init) + ,list)) + +(defun -reductions-r-from (fn init list) + "Return a list of FN's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce-r-from' (which see) is called with the same +arguments. + +This function's anaphoric counterpart is `--reductions-r-from'. + +For other folds, see also `-reductions' and `-reductions-r'." + (declare (important-return-value t)) + (--reductions-r-from (funcall fn it acc) init list)) + +(defmacro --reductions-r (form list) + "Return a list of FORM's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `--reduce-re' (which see) is called with the same arguments. +This is the anaphoric counterpart to `-reductions-r'." + (declare (debug (form list))) + (let ((lv (make-symbol "list-value"))) + `(let ((,lv (reverse ,list))) + (if ,lv + (--reduce-from (cons (let ((acc (car acc))) (ignore acc) ,form) acc) + (list (car ,lv)) + (cdr ,lv)) + ;; Explicit nil binding pacifies lexical "variable left uninitialized" + ;; warning. See issue #377 and upstream https://bugs.gnu.org/47080. + (let ((acc nil) (it nil)) + (ignore acc it) + (list ,form)))))) + +(defun -reductions-r (fn list) + "Return a list of FN's intermediate reductions across reversed LIST. +That is, a list of the intermediate values of the accumulator +when `-reduce-r' (which see) is called with the same arguments. + +This function's anaphoric counterpart is `--reductions-r'. + +For other folds, see also `-reductions-r-from' and +`-reductions'." + (declare (important-return-value t)) + (if list + (--reductions-r (funcall fn it acc) list) + (list (funcall fn)))) + +(defmacro --filter (form list) + "Return a new list of the items in LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-filter'. +For the opposite operation, see also `--remove'." + (declare (debug (form form))) + (let ((r (make-symbol "result"))) + `(let (,r) + (--each ,list (when ,form (push it ,r))) + (nreverse ,r)))) + +(defun -filter (pred list) + "Return a new list of the items in LIST for which PRED returns non-nil. + +Alias: `-select'. + +This function's anaphoric counterpart is `--filter'. + +For similar operations, see also `-keep' and `-remove'." + (declare (important-return-value t)) + (--filter (funcall pred it) list)) + +(defalias '-select '-filter) +(defalias '--select '--filter) + +(defmacro --remove (form list) + "Return a new list of the items in LIST for which FORM evals to nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-remove'. +For the opposite operation, see also `--filter'." + (declare (debug (form form))) + `(--filter (not ,form) ,list)) + +(defun -remove (pred list) + "Return a new list of the items in LIST for which PRED returns nil. + +Alias: `-reject'. + +This function's anaphoric counterpart is `--remove'. + +For similar operations, see also `-keep' and `-filter'." + (declare (important-return-value t)) + (--remove (funcall pred it) list)) + +(defalias '-reject '-remove) +(defalias '--reject '--remove) + +(defmacro --remove-first (form list) + "Remove the first item from LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. This is a +non-destructive operation, but only the front of LIST leading up +to the removed item is a copy; the rest is LIST's original tail. +If no item is removed, then the result is a complete copy. +This is the anaphoric counterpart to `-remove-first'." + (declare (debug (form form))) + (let ((front (make-symbol "front")) + (tail (make-symbol "tail"))) + `(let ((,tail ,list) ,front) + (--each-while ,tail (not ,form) + (push (pop ,tail) ,front)) + (if ,tail + (nconc (nreverse ,front) (cdr ,tail)) + (nreverse ,front))))) + +(defun -remove-first (pred list) + "Remove the first item from LIST for which PRED returns non-nil. +This is a non-destructive operation, but only the front of LIST +leading up to the removed item is a copy; the rest is LIST's +original tail. If no item is removed, then the result is a +complete copy. + +Alias: `-reject-first'. + +This function's anaphoric counterpart is `--remove-first'. + +See also `-map-first', `-remove-item', and `-remove-last'." + (declare (important-return-value t)) + (--remove-first (funcall pred it) list)) + +;; TODO: #'-quoting the macro upsets Emacs 24. +(defalias '-reject-first #'-remove-first) +(defalias '--reject-first '--remove-first) + +(defmacro --remove-last (form list) + "Remove the last item from LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' before evaluating +FORM. The result is a copy of LIST regardless of whether an +element is removed. +This is the anaphoric counterpart to `-remove-last'." + (declare (debug (form form))) + `(nreverse (--remove-first ,form (reverse ,list)))) + +(defun -remove-last (pred list) + "Remove the last item from LIST for which PRED returns non-nil. +The result is a copy of LIST regardless of whether an element is +removed. + +Alias: `-reject-last'. + +This function's anaphoric counterpart is `--remove-last'. + +See also `-map-last', `-remove-item', and `-remove-first'." + (declare (important-return-value t)) + (--remove-last (funcall pred it) list)) + +(defalias '-reject-last '-remove-last) +(defalias '--reject-last '--remove-last) + +(defalias '-remove-item #'remove + "Return a copy of LIST with all occurrences of ITEM removed. +The comparison is done with `equal'. +\n(fn ITEM LIST)") + +(defmacro --keep (form list) + "Eval FORM for each item in LIST and return the non-nil results. +Like `--filter', but returns the non-nil results of FORM instead +of the corresponding elements of LIST. Each element of LIST in +turn is bound to `it' and its index within LIST to `it-index' +before evaluating FORM. +This is the anaphoric counterpart to `-keep'." + (declare (debug (form form))) + (let ((r (make-symbol "result")) + (m (make-symbol "mapped"))) + `(let (,r) + (--each ,list (let ((,m ,form)) (when ,m (push ,m ,r)))) + (nreverse ,r)))) + +(defun -keep (fn list) + "Return a new list of the non-nil results of applying FN to each item in LIST. +Like `-filter', but returns the non-nil results of FN instead of +the corresponding elements of LIST. + +Its anaphoric counterpart is `--keep'." + (declare (important-return-value t)) + (--keep (funcall fn it) list)) + +(defun -non-nil (list) + "Return a copy of LIST with all nil items removed." + (declare (side-effect-free t)) + (--filter it list)) + +(defmacro --map-indexed (form list) + "Eval FORM for each item in LIST and return the list of results. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. This is like +`--map', but additionally makes `it-index' available to FORM. + +This is the anaphoric counterpart to `-map-indexed'." + (declare (debug (form form))) + (let ((r (make-symbol "result"))) + `(let (,r) + (--each ,list + (push ,form ,r)) + (nreverse ,r)))) + +(defun -map-indexed (fn list) + "Apply FN to each index and item in LIST and return the list of results. +This is like `-map', but FN takes two arguments: the index of the +current element within LIST, and the element itself. + +This function's anaphoric counterpart is `--map-indexed'. + +For a side-effecting variant, see also `-each-indexed'." + (declare (important-return-value t)) + (--map-indexed (funcall fn it-index it) list)) + +(defmacro --map-when (pred rep list) + "Anaphoric form of `-map-when'." + (declare (debug (form form form))) + (let ((r (make-symbol "result"))) + `(let (,r) + (--each ,list (!cons (if ,pred ,rep it) ,r)) + (nreverse ,r)))) + +(defun -map-when (pred rep list) + "Use PRED to conditionally apply REP to each item in LIST. +Return a copy of LIST where the items for which PRED returns nil +are unchanged, and the rest are mapped through the REP function. + +Alias: `-replace-where' + +See also: `-update-at'" + (declare (important-return-value t)) + (--map-when (funcall pred it) (funcall rep it) list)) + +(defalias '-replace-where '-map-when) +(defalias '--replace-where '--map-when) + +(defun -map-first (pred rep list) + "Use PRED to determine the first item in LIST to call REP on. +Return a copy of LIST where the first item for which PRED returns +non-nil is replaced with the result of calling REP on that item. + +See also: `-map-when', `-replace-first'" + (declare (important-return-value t)) + (let (front) + (while (and list (not (funcall pred (car list)))) + (push (car list) front) + (!cdr list)) + (if list + (-concat (nreverse front) (cons (funcall rep (car list)) (cdr list))) + (nreverse front)))) + +(defmacro --map-first (pred rep list) + "Anaphoric form of `-map-first'." + (declare (debug (def-form def-form form))) + `(-map-first (lambda (it) (ignore it) ,pred) + (lambda (it) (ignore it) ,rep) + ,list)) + +(defun -map-last (pred rep list) + "Use PRED to determine the last item in LIST to call REP on. +Return a copy of LIST where the last item for which PRED returns +non-nil is replaced with the result of calling REP on that item. + +See also: `-map-when', `-replace-last'" + (declare (important-return-value t)) + (nreverse (-map-first pred rep (reverse list)))) + +(defmacro --map-last (pred rep list) + "Anaphoric form of `-map-last'." + (declare (debug (def-form def-form form))) + `(-map-last (lambda (it) (ignore it) ,pred) + (lambda (it) (ignore it) ,rep) + ,list)) + +(defun -replace (old new list) + "Replace all OLD items in LIST with NEW. + +Elements are compared using `equal'. + +See also: `-replace-at'" + (declare (pure t) (side-effect-free t)) + (--map-when (equal it old) new list)) + +(defun -replace-first (old new list) + "Replace the first occurrence of OLD with NEW in LIST. + +Elements are compared using `equal'. + +See also: `-map-first'" + (declare (pure t) (side-effect-free t)) + (--map-first (equal old it) new list)) + +(defun -replace-last (old new list) + "Replace the last occurrence of OLD with NEW in LIST. + +Elements are compared using `equal'. + +See also: `-map-last'" + (declare (pure t) (side-effect-free t)) + (--map-last (equal old it) new list)) + +(defmacro --mapcat (form list) + "Anaphoric form of `-mapcat'." + (declare (debug (form form))) + `(apply #'append (--map ,form ,list))) + +(defun -mapcat (fn list) + "Return the concatenation of the result of mapping FN over LIST. +Thus function FN should return a list." + (declare (important-return-value t)) + (--mapcat (funcall fn it) list)) + +(defmacro --iterate (form init n) + "Anaphoric version of `-iterate'." + (declare (debug (form form form))) + (let ((res (make-symbol "result")) + (len (make-symbol "n"))) + `(let ((,len ,n)) + (when (> ,len 0) + (let* ((it ,init) + (,res (list it))) + (dotimes (_ (1- ,len)) + (push (setq it ,form) ,res)) + (nreverse ,res)))))) + +(defun -iterate (fun init n) + "Return a list of iterated applications of FUN to INIT. + +This means a list of the form: + + (INIT (FUN INIT) (FUN (FUN INIT)) ...) + +N is the length of the returned list." + (declare (important-return-value t)) + (--iterate (funcall fun it) init n)) + +(defun -flatten (l) + "Take a nested list L and return its contents as a single, flat list. + +Note that because nil represents a list of zero elements (an +empty list), any mention of nil in L will disappear after +flattening. If you need to preserve nils, consider `-flatten-n' +or map them to some unique symbol and then map them back. + +Conses of two atoms are considered \"terminals\", that is, they +aren't flattened further. + +See also: `-flatten-n'" + (declare (pure t) (side-effect-free t)) + (if (and (listp l) (listp (cdr l))) + (-mapcat '-flatten l) + (list l))) + +(defun -flatten-n (num list) + "Flatten NUM levels of a nested LIST. + +See also: `-flatten'" + (declare (pure t) (side-effect-free t)) + (dotimes (_ num) + (setq list (apply #'append (mapcar #'-list list)))) + list) + +(defalias '-concat #'append + "Concatenate all SEQUENCES and make the result a list. +The result is a list whose elements are the elements of all the arguments. +Each argument may be a list, vector or string. + +All arguments except the last argument are copied. The last argument +is just used as the tail of the new list. If the last argument is not +a list, this results in a dotted list. + +As an exception, if all the arguments except the last are nil, and the +last argument is not a list, the return value is that last argument +unaltered, not a list. + +\(fn &rest SEQUENCES)") + +(defalias '-copy #'copy-sequence + "Create a shallow copy of LIST. +The elements of LIST are not copied; they are shared with the original. +\n(fn LIST)") + +(defmacro --splice (pred form list) + "Splice lists generated by FORM in place of items satisfying PRED in LIST. + +Evaluate PRED for each element of LIST in turn bound to `it'. +Whenever the result of PRED is nil, leave that `it' is-is. +Otherwise, evaluate FORM with the same `it' binding still in +place. The result should be a (possibly empty) list of items to +splice in place of `it' in LIST. + +This can be useful as an alternative to the `,@' construct in a +`\\=`' structure, in case you need to splice several lists at +marked positions (for example with keywords). + +This is the anaphoric counterpart to `-splice'." + (declare (debug (form form form))) + (let ((r (make-symbol "result"))) + `(let (,r) + (--each ,list + (if ,pred + (--each ,form (push it ,r)) + (push it ,r))) + (nreverse ,r)))) + +(defun -splice (pred fun list) + "Splice lists generated by FUN in place of items satisfying PRED in LIST. + +Call PRED on each element of LIST. Whenever the result of PRED +is nil, leave that `it' as-is. Otherwise, call FUN on the same +`it' that satisfied PRED. The result should be a (possibly +empty) list of items to splice in place of `it' in LIST. + +This can be useful as an alternative to the `,@' construct in a +`\\=`' structure, in case you need to splice several lists at +marked positions (for example with keywords). + +This function's anaphoric counterpart is `--splice'. + +See also: `-splice-list', `-insert-at'." + (declare (important-return-value t)) + (--splice (funcall pred it) (funcall fun it) list)) + +(defun -splice-list (pred new-list list) + "Splice NEW-LIST in place of elements matching PRED in LIST. + +See also: `-splice', `-insert-at'" + (declare (important-return-value t)) + (-splice pred (lambda (_) new-list) list)) + +(defmacro --splice-list (pred new-list list) + "Anaphoric form of `-splice-list'." + (declare (debug (def-form form form))) + `(-splice-list (lambda (it) (ignore it) ,pred) ,new-list ,list)) + +(defun -cons* (&rest args) + "Make a new list from the elements of ARGS. +The last 2 elements of ARGS are used as the final cons of the +result, so if the final element of ARGS is not a list, the result +is a dotted list. With no ARGS, return nil." + (declare (side-effect-free t)) + (let* ((len (length args)) + (tail (nthcdr (- len 2) args)) + (last (cdr tail))) + (if (null last) + (car args) + (setcdr tail (car last)) + args))) + +(defun -snoc (list elem &rest elements) + "Append ELEM to the end of the list. + +This is like `cons', but operates on the end of list. + +If any ELEMENTS are given, append them to the list as well." + (declare (side-effect-free t)) + (-concat list (list elem) elements)) + +(defmacro --first (form list) + "Return the first item in LIST for which FORM evals to non-nil. +Return nil if no such element is found. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-first'." + (declare (debug (form form))) + (let ((n (make-symbol "needle"))) + `(let (,n) + (--each-while ,list (or (not ,form) + (ignore (setq ,n it)))) + ,n))) + +(defun -first (pred list) + "Return the first item in LIST for which PRED returns non-nil. +Return nil if no such element is found. + +To get the first item in the list no questions asked, +use `-first-item'. + +Alias: `-find'. + +This function's anaphoric counterpart is `--first'." + (declare (important-return-value t)) + (--first (funcall pred it) list)) + +(defalias '-find #'-first) +(defalias '--find '--first) + +(defmacro --some (form list) + "Return non-nil if FORM evals to non-nil for at least one item in LIST. +If so, return the first such result of FORM. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-some'." + (declare (debug (form form))) + (let ((n (make-symbol "needle"))) + `(let (,n) + (--each-while ,list (not (setq ,n ,form))) + ,n))) + +(defun -some (pred list) + "Return (PRED x) for the first LIST item where (PRED x) is non-nil, else nil. + +Alias: `-any'. + +This function's anaphoric counterpart is `--some'." + (declare (important-return-value t)) + (--some (funcall pred it) list)) + +(defalias '-any '-some) +(defalias '--any '--some) + +(defmacro --every (form list) + "Return non-nil if FORM evals to non-nil for all items in LIST. +If so, return the last such result of FORM. Otherwise, once an +item is reached for which FORM yields nil, return nil without +evaluating FORM for any further LIST elements. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. + +This macro is like `--every-p', but on success returns the last +non-nil result of FORM instead of just t. + +This is the anaphoric counterpart to `-every'." + (declare (debug (form form))) + (let ((a (make-symbol "all"))) + `(let ((,a t)) + (--each-while ,list (setq ,a ,form)) + ,a))) + +(defun -every (pred list) + "Return non-nil if PRED returns non-nil for all items in LIST. +If so, return the last such result of PRED. Otherwise, once an +item is reached for which PRED returns nil, return nil without +calling PRED on any further LIST elements. + +This function is like `-every-p', but on success returns the last +non-nil result of PRED instead of just t. + +This function's anaphoric counterpart is `--every'." + (declare (important-return-value t)) + (--every (funcall pred it) list)) + +(defmacro --last (form list) + "Anaphoric form of `-last'." + (declare (debug (form form))) + (let ((n (make-symbol "needle"))) + `(let (,n) + (--each ,list + (when ,form (setq ,n it))) + ,n))) + +(defun -last (pred list) + "Return the last x in LIST where (PRED x) is non-nil, else nil." + (declare (important-return-value t)) + (--last (funcall pred it) list)) + +(defalias '-first-item #'car + "Return the first item of LIST, or nil on an empty list. + +See also: `-second-item', `-last-item', etc. + +\(fn LIST)") + +;; Ensure that calls to `-first-item' are compiled to a single opcode, +;; just like `car'. +(put '-first-item 'byte-opcode 'byte-car) +(put '-first-item 'byte-compile 'byte-compile-one-arg) +(put '-first-item 'pure t) +(put '-first-item 'side-effect-free t) + +(defalias '-second-item #'cadr + "Return the second item of LIST, or nil if LIST is too short. + +See also: `-first-item', `-third-item', etc. + +\(fn LIST)") + +(put '-second-item 'pure t) +(put '-second-item 'side-effect-free t) + +(defalias '-third-item + (if (fboundp 'caddr) + #'caddr + (lambda (list) (car (cddr list)))) + "Return the third item of LIST, or nil if LIST is too short. + +See also: `-second-item', `-fourth-item', etc. + +\(fn LIST)") + +(put '-third-item 'pure t) +(put '-third-item 'side-effect-free t) + +(defalias '-fourth-item + (if (fboundp 'cadddr) + #'cadddr + (lambda (list) (cadr (cddr list)))) + "Return the fourth item of LIST, or nil if LIST is too short. + +See also: `-third-item', `-fifth-item', etc. + +\(fn LIST)") + +(put '-fourth-item 'pure t) +(put '-fourth-item 'side-effect-free t) + +(defun -fifth-item (list) + "Return the fifth item of LIST, or nil if LIST is too short. + +See also: `-fourth-item', `-last-item', etc." + (declare (pure t) (side-effect-free t)) + (car (cddr (cddr list)))) + +(defun -last-item (list) + "Return the last item of LIST, or nil on an empty list. + +See also: `-first-item', etc." + (declare (pure t) (side-effect-free t)) + (car (last list))) + +(static-if (fboundp 'gv-define-setter) + (gv-define-setter -last-item (val x) `(setcar (last ,x) ,val)) + (defsetf -last-item (x) (val) `(setcar (last ,x) ,val))) + +(defun -butlast (list) + "Return a list of all items in list except for the last." + ;; no alias as we don't want magic optional argument + (declare (pure t) (side-effect-free t)) + (butlast list)) + +(defmacro --count (pred list) + "Anaphoric form of `-count'." + (declare (debug (form form))) + (let ((r (make-symbol "result"))) + `(let ((,r 0)) + (--each ,list (when ,pred (setq ,r (1+ ,r)))) + ,r))) + +(defun -count (pred list) + "Counts the number of items in LIST where (PRED item) is non-nil." + (declare (important-return-value t)) + (--count (funcall pred it) list)) + +(defun ---truthy? (obj) + "Return OBJ as a boolean value (t or nil)." + (declare (pure t) (side-effect-free error-free)) + (and obj t)) + +(defmacro --any? (form list) + "Anaphoric form of `-any?'." + (declare (debug (form form))) + `(and (--some ,form ,list) t)) + +(defun -any? (pred list) + "Return t if (PRED X) is non-nil for any X in LIST, else nil. + +Alias: `-any-p', `-some?', `-some-p'" + (declare (important-return-value t)) + (--any? (funcall pred it) list)) + +(defalias '-some? '-any?) +(defalias '--some? '--any?) +(defalias '-any-p '-any?) +(defalias '--any-p '--any?) +(defalias '-some-p '-any?) +(defalias '--some-p '--any?) + +(defmacro --all? (form list) + "Return t if FORM evals to non-nil for all items in LIST. +Otherwise, once an item is reached for which FORM yields nil, +return nil without evaluating FORM for any further LIST elements. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. + +The similar macro `--every' is more widely useful, since it +returns the last non-nil result of FORM instead of just t on +success. + +Alias: `--all-p', `--every-p', `--every?'. + +This is the anaphoric counterpart to `-all?'." + (declare (debug (form form))) + `(and (--every ,form ,list) t)) + +(defun -all? (pred list) + "Return t if (PRED X) is non-nil for all X in LIST, else nil. +In the latter case, stop after the first X for which (PRED X) is +nil, without calling PRED on any subsequent elements of LIST. + +The similar function `-every' is more widely useful, since it +returns the last non-nil result of PRED instead of just t on +success. + +Alias: `-all-p', `-every-p', `-every?'. + +This function's anaphoric counterpart is `--all?'." + (declare (important-return-value t)) + (--all? (funcall pred it) list)) + +(defalias '-every? '-all?) +(defalias '--every? '--all?) +(defalias '-all-p '-all?) +(defalias '--all-p '--all?) +(defalias '-every-p '-all?) +(defalias '--every-p '--all?) + +(defmacro --none? (form list) + "Anaphoric form of `-none?'." + (declare (debug (form form))) + `(--all? (not ,form) ,list)) + +(defun -none? (pred list) + "Return t if (PRED X) is nil for all X in LIST, else nil. + +Alias: `-none-p'" + (declare (important-return-value t)) + (--none? (funcall pred it) list)) + +(defalias '-none-p '-none?) +(defalias '--none-p '--none?) + +(defmacro --only-some? (form list) + "Anaphoric form of `-only-some?'." + (declare (debug (form form))) + (let ((y (make-symbol "yes")) + (n (make-symbol "no"))) + `(let (,y ,n) + (--each-while ,list (not (and ,y ,n)) + (if ,form (setq ,y t) (setq ,n t))) + (---truthy? (and ,y ,n))))) + +(defun -only-some? (pred list) + "Return t if different LIST items both satisfy and do not satisfy PRED. +That is, if PRED returns both nil for at least one item, and +non-nil for at least one other item in LIST. Return nil if all +items satisfy the predicate or none of them do. + +Alias: `-only-some-p'" + (declare (important-return-value t)) + (--only-some? (funcall pred it) list)) + +(defalias '-only-some-p '-only-some?) +(defalias '--only-some-p '--only-some?) + +(defun -slice (list from &optional to step) + "Return copy of LIST, starting from index FROM to index TO. + +FROM or TO may be negative. These values are then interpreted +modulo the length of the list. + +If STEP is a number, only each STEPth item in the resulting +section is returned. Defaults to 1." + (declare (side-effect-free t)) + (let ((length (length list)) + (new-list nil)) + ;; to defaults to the end of the list + (setq to (or to length)) + (setq step (or step 1)) + ;; handle negative indices + (when (< from 0) + (setq from (mod from length))) + (when (< to 0) + (setq to (mod to length))) + + ;; iterate through the list, keeping the elements we want + (--each-while list (< it-index to) + (when (and (>= it-index from) + (= (mod (- from it-index) step) 0)) + (push it new-list))) + (nreverse new-list))) + +(defmacro --take-while (form list) + "Take successive items from LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. Return a new +list of the successive elements from the start of LIST for which +FORM evaluates to non-nil. +This is the anaphoric counterpart to `-take-while'." + (declare (debug (form form))) + (let ((r (make-symbol "result"))) + `(let (,r) + (--each-while ,list ,form (push it ,r)) + (nreverse ,r)))) + +(defun -take-while (pred list) + "Take successive items from LIST for which PRED returns non-nil. +PRED is a function of one argument. Return a new list of the +successive elements from the start of LIST for which PRED returns +non-nil. + +This function's anaphoric counterpart is `--take-while'. + +For another variant, see also `-drop-while'." + (declare (important-return-value t)) + (--take-while (funcall pred it) list)) + +(defmacro --drop-while (form list) + "Drop successive items from LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. Return the +tail (not a copy) of LIST starting from its first element for +which FORM evaluates to nil. +This is the anaphoric counterpart to `-drop-while'." + (declare (debug (form form))) + (let ((l (make-symbol "list"))) + `(let ((,l ,list)) + (--each-while ,l ,form (pop ,l)) + ,l))) + +(defun -drop-while (pred list) + "Drop successive items from LIST for which PRED returns non-nil. +PRED is a function of one argument. Return the tail (not a copy) +of LIST starting from its first element for which PRED returns +nil. + +This function's anaphoric counterpart is `--drop-while'. + +For another variant, see also `-take-while'." + (declare (important-return-value t)) + (--drop-while (funcall pred it) list)) + +;; Added in Emacs 29. +(static-if (fboundp 'take) + (defun dash--take (n list) + "Return the first N elements of LIST. +Like `take', but ensure result is fresh." + (let ((prefix (take n list))) + (if (eq prefix list) + ;; If same list is returned, make a copy. + (copy-sequence prefix) + prefix)))) + +(defun -take (n list) + "Return a copy of the first N items in LIST. +Return a copy of LIST if it contains N items or fewer. +Return nil if N is zero or less. + +See also: `-take-last'." + (declare (side-effect-free t)) + (static-if (fboundp 'dash--take) + (dash--take n list) + (--take-while (< it-index n) list))) + +(defun -take-last (n list) + "Return a copy of the last N items of LIST in order. +Return a copy of LIST if it contains N items or fewer. +Return nil if N is zero or less. + +See also: `-take'." + (declare (side-effect-free t)) + (copy-sequence (last list n))) + +(defalias '-drop #'nthcdr + "Return the tail (not a copy) of LIST without the first N items. +Return nil if LIST contains N items or fewer. +Return LIST if N is zero or less. + +For another variant, see also `-drop-last'. +\n(fn N LIST)") + +(defun -drop-last (n list) + "Return a copy of LIST without its last N items. +Return a copy of LIST if N is zero or less. +Return nil if LIST contains N items or fewer. + +See also: `-drop'." + (declare (side-effect-free t)) + (static-if (fboundp 'dash--take) + (dash--take (- (length list) n) list) + (nbutlast (copy-sequence list) n))) + +(defun -split-at (n list) + "Split LIST into two sublists after the Nth element. +The result is a list of two elements (TAKE DROP) where TAKE is a +new list of the first N elements of LIST, and DROP is the +remaining elements of LIST (not a copy). TAKE and DROP are like +the results of `-take' and `-drop', respectively, but the split +is done in a single list traversal." + (declare (side-effect-free t)) + (let (result) + (--each-while list (< it-index n) + (push (pop list) result)) + (list (nreverse result) list))) + +(defun -rotate (n list) + "Rotate LIST N places to the right (left if N is negative). +The time complexity is O(n)." + (declare (pure t) (side-effect-free t)) + (cond ((null list) ()) + ((zerop n) (copy-sequence list)) + ((let* ((len (length list)) + (n-mod-len (mod n len)) + (new-tail-len (- len n-mod-len))) + (append (nthcdr new-tail-len list) (-take new-tail-len list)))))) + +(defun -insert-at (n x list) + "Return a list with X inserted into LIST at position N. + +See also: `-splice', `-splice-list'" + (declare (pure t) (side-effect-free t)) + (let ((split-list (-split-at n list))) + (nconc (car split-list) (cons x (cadr split-list))))) + +(defun -replace-at (n x list) + "Return a list with element at Nth position in LIST replaced with X. + +See also: `-replace'" + (declare (pure t) (side-effect-free t)) + (let ((split-list (-split-at n list))) + (nconc (car split-list) (cons x (cdr (cadr split-list)))))) + +(defun -update-at (n func list) + "Use FUNC to update the Nth element of LIST. +Return a copy of LIST where the Nth element is replaced with the +result of calling FUNC on it. + +See also: `-map-when'" + (declare (important-return-value t)) + (let ((split-list (-split-at n list))) + (nconc (car split-list) + (cons (funcall func (car (cadr split-list))) + (cdr (cadr split-list)))))) + +(defmacro --update-at (n form list) + "Anaphoric version of `-update-at'." + (declare (debug (form def-form form))) + `(-update-at ,n (lambda (it) (ignore it) ,form) ,list)) + +(defun -remove-at (n list) + "Return LIST with its element at index N removed. +That is, remove any element selected as (nth N LIST) from LIST +and return the result. + +This is a non-destructive operation: parts of LIST (but not +necessarily all of it) are copied as needed to avoid +destructively modifying it. + +See also: `-remove-at-indices', `-remove'." + (declare (pure t) (side-effect-free t)) + (if (zerop n) + (cdr list) + (--remove-first (= it-index n) list))) + +(defun -remove-at-indices (indices list) + "Return LIST with its elements at INDICES removed. +That is, for each index I in INDICES, remove any element selected +as (nth I LIST) from LIST. + +This is a non-destructive operation: parts of LIST (but not +necessarily all of it) are copied as needed to avoid +destructively modifying it. + +See also: `-remove-at', `-remove'." + (declare (pure t) (side-effect-free t)) + (setq indices (--drop-while (< it 0) (-sort #'< indices))) + (let ((i (pop indices)) res) + (--each-while list i + (pop list) + (if (/= it-index i) + (push it res) + (while (and indices (= (car indices) i)) + (pop indices)) + (setq i (pop indices)))) + (nconc (nreverse res) list))) + +(defmacro --split-with (pred list) + "Anaphoric form of `-split-with'." + (declare (debug (form form))) + (let ((l (make-symbol "list")) + (r (make-symbol "result")) + (c (make-symbol "continue"))) + `(let ((,l ,list) + (,r nil) + (,c t)) + (while (and ,l ,c) + (let ((it (car ,l))) + (if (not ,pred) + (setq ,c nil) + (!cons it ,r) + (!cdr ,l)))) + (list (nreverse ,r) ,l)))) + +(defun -split-with (pred list) + "Split LIST into a prefix satisfying PRED, and the rest. +The first sublist is the prefix of LIST with successive elements +satisfying PRED, and the second sublist is the remaining elements +that do not. The result is like performing + + ((-take-while PRED LIST) (-drop-while PRED LIST)) + +but in no more than a single pass through LIST." + (declare (important-return-value t)) + (--split-with (funcall pred it) list)) + +(defmacro -split-on (item list) + "Split the LIST each time ITEM is found. + +Unlike `-partition-by', the ITEM is discarded from the results. +Empty lists are also removed from the result. + +Comparison is done by `equal'. + +See also `-split-when'" + (declare (debug (def-form form))) + `(-split-when (lambda (it) (equal it ,item)) ,list)) + +(defmacro --split-when (form list) + "Anaphoric version of `-split-when'." + (declare (debug (def-form form))) + `(-split-when (lambda (it) (ignore it) ,form) ,list)) + +(defun -split-when (fn list) + "Split the LIST on each element where FN returns non-nil. + +Unlike `-partition-by', the \"matched\" element is discarded from +the results. Empty lists are also removed from the result. + +This function can be thought of as a generalization of +`split-string'." + (declare (important-return-value t)) + (let (r s) + (while list + (if (not (funcall fn (car list))) + (push (car list) s) + (when s (push (nreverse s) r)) + (setq s nil)) + (!cdr list)) + (when s (push (nreverse s) r)) + (nreverse r))) + +(defmacro --separate (form list) + "Anaphoric form of `-separate'." + (declare (debug (form form))) + (let ((y (make-symbol "yes")) + (n (make-symbol "no"))) + `(let (,y ,n) + (--each ,list (if ,form (!cons it ,y) (!cons it ,n))) + (list (nreverse ,y) (nreverse ,n))))) + +(defun -separate (pred list) + "Split LIST into two sublists based on whether items satisfy PRED. +The result is like performing + + ((-filter PRED LIST) (-remove PRED LIST)) + +but in a single pass through LIST." + (declare (important-return-value t)) + (--separate (funcall pred it) list)) + +(defun dash--partition-all-in-steps-reversed (n step list) + "Like `-partition-all-in-steps', but the result is reversed." + (when (< step 1) + (signal 'wrong-type-argument + `("Step size < 1 results in juicy infinite loops" ,step))) + (let (result) + (while list + (push (-take n list) result) + (setq list (nthcdr step list))) + result)) + +(defun -partition-all-in-steps (n step list) + "Partition LIST into sublists of length N that are STEP items apart. +Adjacent groups may overlap if N exceeds the STEP stride. +Trailing groups may contain less than N items." + (declare (pure t) (side-effect-free t)) + (nreverse (dash--partition-all-in-steps-reversed n step list))) + +(defun -partition-in-steps (n step list) + "Partition LIST into sublists of length N that are STEP items apart. +Like `-partition-all-in-steps', but if there are not enough items +to make the last group N-sized, those items are discarded." + (declare (pure t) (side-effect-free t)) + (let ((result (dash--partition-all-in-steps-reversed n step list))) + (while (and result (< (length (car result)) n)) + (pop result)) + (nreverse result))) + +(defun -partition-all (n list) + "Return a new list with the items in LIST grouped into N-sized sublists. +The last group may contain less than N items." + (declare (pure t) (side-effect-free t)) + (-partition-all-in-steps n n list)) + +(defun -partition (n list) + "Return a new list with the items in LIST grouped into N-sized sublists. +If there are not enough items to make the last group N-sized, +those items are discarded." + (declare (pure t) (side-effect-free t)) + (-partition-in-steps n n list)) + +(defmacro --partition-by (form list) + "Anaphoric form of `-partition-by'." + (declare (debug (form form))) + (let ((r (make-symbol "result")) + (s (make-symbol "sublist")) + (v (make-symbol "value")) + (n (make-symbol "new-value")) + (l (make-symbol "list"))) + `(let ((,l ,list)) + (when ,l + (let* ((,r nil) + (it (car ,l)) + (,s (list it)) + (,v ,form) + (,l (cdr ,l))) + (while ,l + (let* ((it (car ,l)) + (,n ,form)) + (unless (equal ,v ,n) + (!cons (nreverse ,s) ,r) + (setq ,s nil) + (setq ,v ,n)) + (!cons it ,s) + (!cdr ,l))) + (!cons (nreverse ,s) ,r) + (nreverse ,r)))))) + +(defun -partition-by (fn list) + "Apply FN to each item in LIST, splitting it each time FN returns a new value." + (declare (important-return-value t)) + (--partition-by (funcall fn it) list)) + +(defmacro --partition-by-header (form list) + "Anaphoric form of `-partition-by-header'." + (declare (debug (form form))) + (let ((r (make-symbol "result")) + (s (make-symbol "sublist")) + (h (make-symbol "header-value")) + (b (make-symbol "seen-body?")) + (n (make-symbol "new-value")) + (l (make-symbol "list"))) + `(let ((,l ,list)) + (when ,l + (let* ((,r nil) + (it (car ,l)) + (,s (list it)) + (,h ,form) + (,b nil) + (,l (cdr ,l))) + (while ,l + (let* ((it (car ,l)) + (,n ,form)) + (if (equal ,h ,n) + (when ,b + (!cons (nreverse ,s) ,r) + (setq ,s nil) + (setq ,b nil)) + (setq ,b t)) + (!cons it ,s) + (!cdr ,l))) + (!cons (nreverse ,s) ,r) + (nreverse ,r)))))) + +(defun -partition-by-header (fn list) + "Apply FN to the first item in LIST. That is the header +value. Apply FN to each item in LIST, splitting it each time FN +returns the header value, but only after seeing at least one +other value (the body)." + (declare (important-return-value t)) + (--partition-by-header (funcall fn it) list)) + +(defmacro --partition-after-pred (form list) + "Partition LIST after each element for which FORM evaluates to non-nil. +Each element of LIST in turn is bound to `it' before evaluating +FORM. + +This is the anaphoric counterpart to `-partition-after-pred'." + (let ((l (make-symbol "list")) + (r (make-symbol "result")) + (s (make-symbol "sublist"))) + `(let ((,l ,list) ,r ,s) + (when ,l + (--each ,l + (push it ,s) + (when ,form + (push (nreverse ,s) ,r) + (setq ,s ()))) + (when ,s + (push (nreverse ,s) ,r)) + (nreverse ,r))))) + +(defun -partition-after-pred (pred list) + "Partition LIST after each element for which PRED returns non-nil. + +This function's anaphoric counterpart is `--partition-after-pred'." + (declare (important-return-value t)) + (--partition-after-pred (funcall pred it) list)) + +(defun -partition-before-pred (pred list) + "Partition directly before each time PRED is true on an element of LIST." + (declare (important-return-value t)) + (nreverse (-map #'reverse + (-partition-after-pred pred (reverse list))))) + +(defun -partition-after-item (item list) + "Partition directly after each time ITEM appears in LIST." + (declare (pure t) (side-effect-free t)) + (-partition-after-pred (lambda (ele) (equal ele item)) + list)) + +(defun -partition-before-item (item list) + "Partition directly before each time ITEM appears in LIST." + (declare (pure t) (side-effect-free t)) + (-partition-before-pred (lambda (ele) (equal ele item)) + list)) + +(defmacro --group-by (form list) + "Anaphoric form of `-group-by'." + (declare (debug t)) + (let ((n (make-symbol "n")) + (k (make-symbol "k")) + (grp (make-symbol "grp"))) + `(nreverse + (-map + (lambda (,n) + (cons (car ,n) + (nreverse (cdr ,n)))) + (--reduce-from + (let* ((,k (,@form)) + (,grp (assoc ,k acc))) + (if ,grp + (setcdr ,grp (cons it (cdr ,grp))) + (push + (list ,k it) + acc)) + acc) + nil ,list))))) + +(defun -group-by (fn list) + "Separate LIST into an alist whose keys are FN applied to the +elements of LIST. Keys are compared by `equal'." + (declare (important-return-value t)) + (--group-by (funcall fn it) list)) + +(defun -interpose (sep list) + "Return a new list of all elements in LIST separated by SEP." + (declare (side-effect-free t)) + (let (result) + (when list + (!cons (car list) result) + (!cdr list)) + (while list + (setq result (cons (car list) (cons sep result))) + (!cdr list)) + (nreverse result))) + +(defun -interleave (&rest lists) + "Return a new list of the first item in each list, then the second etc." + (declare (side-effect-free t)) + (when lists + (let (result) + (while (-none? 'null lists) + (--each lists (!cons (car it) result)) + (setq lists (-map 'cdr lists))) + (nreverse result)))) + +(defmacro --zip-with (form list1 list2) + "Zip LIST1 and LIST2 into a new list according to FORM. +That is, evaluate FORM for each item pair from the two lists, and +return the list of results. The result is as long as the shorter +list. + +Each element of LIST1 and each element of LIST2 in turn are bound +pairwise to `it' and `other', respectively, and their index +within the list to `it-index', before evaluating FORM. + +This is the anaphoric counterpart to `-zip-with'." + (declare (debug (form form form))) + (let ((r (make-symbol "result")) + (l2 (make-symbol "list2"))) + `(let ((,l2 ,list2) ,r) + (--each-while ,list1 ,l2 + (let ((other (pop ,l2))) + (ignore other) + (push ,form ,r))) + (nreverse ,r)))) + +(defun -zip-with (fn list1 list2) + "Zip LIST1 and LIST2 into a new list using the function FN. +That is, apply FN pairwise taking as first argument the next +element of LIST1 and as second argument the next element of LIST2 +at the corresponding position. The result is as long as the +shorter list. + +This function's anaphoric counterpart is `--zip-with'. + +For other zips, see also `-zip-lists' and `-zip-fill'." + (declare (important-return-value t)) + (--zip-with (funcall fn it other) list1 list2)) + +(defun -zip-lists (&rest lists) + "Zip LISTS together. + +Group the head of each list, followed by the second element of +each list, and so on. The number of returned groupings is equal +to the length of the shortest input list, and the length of each +grouping is equal to the number of input LISTS. + +The return value is always a list of proper lists, in contrast to +`-zip' which returns a list of dotted pairs when only two input +LISTS are provided. + +See also: `-zip-pair'." + (declare (pure t) (side-effect-free t)) + (when lists + (let (results) + (while (--every it lists) + (push (mapcar #'car lists) results) + (setq lists (mapcar #'cdr lists))) + (nreverse results)))) + +(defun -zip-lists-fill (fill-value &rest lists) + "Zip LISTS together, padding shorter lists with FILL-VALUE. +This is like `-zip-lists' (which see), except it retains all +elements at positions beyond the end of the shortest list. The +number of returned groupings is equal to the length of the +longest input list, and the length of each grouping is equal to +the number of input LISTS." + (declare (pure t) (side-effect-free t)) + (when lists + (let (results) + (while (--some it lists) + (push (--map (if it (car it) fill-value) lists) results) + (setq lists (mapcar #'cdr lists))) + (nreverse results)))) + +(defun -unzip-lists (lists) + "Unzip LISTS. + +This works just like `-zip-lists' (which see), but takes a list +of lists instead of a variable number of arguments, such that + + (-unzip-lists (-zip-lists ARGS...)) + +is identity (given that the lists comprising ARGS are of the same +length)." + (declare (pure t) (side-effect-free t)) + (apply #'-zip-lists lists)) + +(defalias 'dash--length= + (if (fboundp 'length=) + #'length= + (lambda (list length) + (cond ((< length 0) nil) + ((zerop length) (null list)) + ((let ((last (nthcdr (1- length) list))) + (and last (null (cdr last)))))))) + "Return non-nil if LIST is of LENGTH. +This is a compatibility shim for `length=' in Emacs 28. +\n(fn LIST LENGTH)") + +(defun dash--zip-lists-or-pair (_form &rest lists) + "Return a form equivalent to applying `-zip' to LISTS. +This `compiler-macro' warns about discouraged `-zip' usage and +delegates to `-zip-lists' or `-zip-pair' depending on the number +of LISTS." + (if (not (dash--length= lists 2)) + (cons #'-zip-lists lists) + (let ((pair (cons #'-zip-pair lists)) + (msg "Use -zip-pair instead of -zip to get a list of pairs")) + (if (fboundp 'macroexp-warn-and-return) + (macroexp-warn-and-return msg pair) + (message msg) + pair)))) + +(defun -zip (&rest lists) + "Zip LISTS together. + +Group the head of each list, followed by the second element of +each list, and so on. The number of returned groupings is equal +to the length of the shortest input list, and the number of items +in each grouping is equal to the number of input LISTS. + +If only two LISTS are provided as arguments, return the groupings +as a list of dotted pairs. Otherwise, return the groupings as a +list of proper lists. + +Since the return value changes form depending on the number of +arguments, it is generally recommended to use `-zip-lists' +instead, or `-zip-pair' if a list of dotted pairs is desired. + +See also: `-unzip'." + (declare (compiler-macro dash--zip-lists-or-pair) + (pure t) (side-effect-free t)) + ;; For backward compatibility, return a list of dotted pairs if two + ;; arguments were provided. + (apply (if (dash--length= lists 2) #'-zip-pair #'-zip-lists) lists)) + +(defun -zip-pair (&rest lists) + "Zip LIST1 and LIST2 together. + +Make a pair with the head of each list, followed by a pair with +the second element of each list, and so on. The number of pairs +returned is equal to the length of the shorter input list. + +See also: `-zip-lists'." + (declare (advertised-calling-convention (list1 list2) "2.20.0") + (pure t) (side-effect-free t)) + (if (dash--length= lists 2) + (--zip-with (cons it other) (car lists) (cadr lists)) + (apply #'-zip-lists lists))) + +(defun -zip-fill (fill-value &rest lists) + "Zip LISTS together, padding shorter lists with FILL-VALUE. +This is like `-zip' (which see), except it retains all elements +at positions beyond the end of the shortest list. The number of +returned groupings is equal to the length of the longest input +list, and the length of each grouping is equal to the number of +input LISTS. + +Since the return value changes form depending on the number of +arguments, it is generally recommended to use `-zip-lists-fill' +instead, unless a list of dotted pairs is explicitly desired." + (declare (pure t) (side-effect-free t)) + (cond ((null lists) ()) + ((dash--length= lists 2) + (let ((list1 (car lists)) + (list2 (cadr lists)) + results) + (while (or list1 list2) + (push (cons (if list1 (pop list1) fill-value) + (if list2 (pop list2) fill-value)) + results)) + (nreverse results))) + ((apply #'-zip-lists-fill fill-value lists)))) + +(defun -unzip (lists) + "Unzip LISTS. + +This works just like `-zip' (which see), but takes a list of +lists instead of a variable number of arguments, such that + + (-unzip (-zip L1 L2 L3 ...)) + +is identity (given that the lists are of the same length, and +that `-zip' is not called with two arguments, because of the +caveat described in its docstring). + +Note in particular that calling `-unzip' on a list of two lists +will return a list of dotted pairs. + +Since the return value changes form depending on the number of +LISTS, it is generally recommended to use `-unzip-lists' instead." + (declare (pure t) (side-effect-free t)) + (apply #'-zip lists)) + +(defun -cycle (list) + "Return an infinite circular copy of LIST. +The returned list cycles through the elements of LIST and repeats +from the beginning." + (declare (pure t) (side-effect-free t)) + ;; Also works with sequences that aren't lists. + (let ((newlist (append list ()))) + (nconc newlist newlist))) + +(defun -pad (fill-value &rest lists) + "Pad each of LISTS with FILL-VALUE until they all have equal lengths. + +Ensure all LISTS are as long as the longest one by repeatedly +appending FILL-VALUE to the shorter lists, and return the +resulting LISTS." + (declare (pure t) (side-effect-free t)) + (let* ((lens (mapcar #'length lists)) + (maxlen (apply #'max 0 lens))) + (--map (append it (make-list (- maxlen (pop lens)) fill-value)) lists))) + +(defmacro --annotate (form list) + "Pair each item in LIST with the result of evaluating FORM. + +Return an alist of (RESULT . ITEM), where each ITEM is the +corresponding element of LIST, and RESULT is the value obtained +by evaluating FORM with ITEM bound to `it'. + +This is the anaphoric counterpart to `-annotate'." + (declare (debug (form form))) + `(--map (cons ,form it) ,list)) + +(defun -annotate (fn list) + "Pair each item in LIST with the result of passing it to FN. + +Return an alist of (RESULT . ITEM), where each ITEM is the +corresponding element of LIST, and RESULT is the value obtained +by calling FN on ITEM. + +This function's anaphoric counterpart is `--annotate'." + (declare (important-return-value t)) + (--annotate (funcall fn it) list)) + +(defun dash--table-carry (lists restore-lists &optional re) + "Helper for `-table' and `-table-flat'. + +If a list overflows, carry to the right and reset the list." + (while (not (or (car lists) + (equal lists '(nil)))) + (setcar lists (car restore-lists)) + (pop (cadr lists)) + (!cdr lists) + (!cdr restore-lists) + (when re + (push (nreverse (car re)) (cadr re)) + (setcar re nil) + (!cdr re)))) + +(defun -table (fn &rest lists) + "Compute outer product of LISTS using function FN. + +The function FN should have the same arity as the number of +supplied lists. + +The outer product is computed by applying fn to all possible +combinations created by taking one element from each list in +order. The dimension of the result is (length lists). + +See also: `-table-flat'" + (declare (important-return-value t)) + (let ((restore-lists (copy-sequence lists)) + (last-list (last lists)) + (re (make-list (length lists) nil))) + (while (car last-list) + (let ((item (apply fn (-map 'car lists)))) + (push item (car re)) + (setcar lists (cdar lists)) ;; silence byte compiler + (dash--table-carry lists restore-lists re))) + (nreverse (car (last re))))) + +(defun -table-flat (fn &rest lists) + "Compute flat outer product of LISTS using function FN. + +The function FN should have the same arity as the number of +supplied lists. + +The outer product is computed by applying fn to all possible +combinations created by taking one element from each list in +order. The results are flattened, ignoring the tensor structure +of the result. This is equivalent to calling: + + (-flatten-n (1- (length lists)) (apply \\='-table fn lists)) + +but the implementation here is much more efficient. + +See also: `-flatten-n', `-table'" + (declare (important-return-value t)) + (let ((restore-lists (copy-sequence lists)) + (last-list (last lists)) + re) + (while (car last-list) + (let ((item (apply fn (-map 'car lists)))) + (push item re) + (setcar lists (cdar lists)) ;; silence byte compiler + (dash--table-carry lists restore-lists))) + (nreverse re))) + +(defmacro --find-index (form list) + "Return the first index in LIST for which FORM evals to non-nil. +Return nil if no such index is found. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-find-index'." + (declare (debug (form form))) + `(--some (and ,form it-index) ,list)) + +(defun -find-index (pred list) + "Return the index of the first item satisfying PRED in LIST. +Return nil if no such item is found. + +PRED is called with one argument, the current list element, until +it returns non-nil, at which point the search terminates. + +This function's anaphoric counterpart is `--find-index'. + +See also: `-first', `-find-last-index'." + (declare (important-return-value t)) + (--find-index (funcall pred it) list)) + +(defun -elem-index (elem list) + "Return the first index of ELEM in LIST. +That is, the index within LIST of the first element that is +`equal' to ELEM. Return nil if there is no such element. + +See also: `-find-index'." + (declare (pure t) (side-effect-free t)) + (--find-index (equal elem it) list)) + +(defmacro --find-indices (form list) + "Return the list of indices in LIST for which FORM evals to non-nil. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-find-indices'." + (declare (debug (form form))) + `(--keep (and ,form it-index) ,list)) + +(defun -find-indices (pred list) + "Return the list of indices in LIST satisfying PRED. + +Each element of LIST in turn is passed to PRED. If the result is +non-nil, the index of that element in LIST is included in the +result. The returned indices are in ascending order, i.e., in +the same order as they appear in LIST. + +This function's anaphoric counterpart is `--find-indices'. + +See also: `-find-index', `-elem-indices'." + (declare (important-return-value t)) + (--find-indices (funcall pred it) list)) + +(defun -elem-indices (elem list) + "Return the list of indices at which ELEM appears in LIST. +That is, the indices of all elements of LIST `equal' to ELEM, in +the same ascending order as they appear in LIST." + (declare (pure t) (side-effect-free t)) + (--find-indices (equal elem it) list)) + +(defmacro --find-last-index (form list) + "Return the last index in LIST for which FORM evals to non-nil. +Return nil if no such index is found. +Each element of LIST in turn is bound to `it' and its index +within LIST to `it-index' before evaluating FORM. +This is the anaphoric counterpart to `-find-last-index'." + (declare (debug (form form))) + (let ((i (make-symbol "index"))) + `(let (,i) + (--each ,list + (when ,form (setq ,i it-index))) + ,i))) + +(defun -find-last-index (pred list) + "Return the index of the last item satisfying PRED in LIST. +Return nil if no such item is found. + +Predicate PRED is called with one argument each time, namely the +current list element. + +This function's anaphoric counterpart is `--find-last-index'. + +See also: `-last', `-find-index'." + (declare (important-return-value t)) + (--find-last-index (funcall pred it) list)) + +(defun -select-by-indices (indices list) + "Return a list whose elements are elements from LIST selected +as `(nth i list)` for all i from INDICES." + (declare (pure t) (side-effect-free t)) + (let (r) + (--each indices + (!cons (nth it list) r)) + (nreverse r))) + +(defun -select-columns (columns table) + "Select COLUMNS from TABLE. + +TABLE is a list of lists where each element represents one row. +It is assumed each row has the same length. + +Each row is transformed such that only the specified COLUMNS are +selected. + +See also: `-select-column', `-select-by-indices'" + (declare (pure t) (side-effect-free t)) + (--map (-select-by-indices columns it) table)) + +(defun -select-column (column table) + "Select COLUMN from TABLE. + +TABLE is a list of lists where each element represents one row. +It is assumed each row has the same length. + +The single selected column is returned as a list. + +See also: `-select-columns', `-select-by-indices'" + (declare (pure t) (side-effect-free t)) + (--mapcat (-select-by-indices (list column) it) table)) + +(defmacro -> (x &optional form &rest more) + "Thread the expr through the forms. Insert X as the second item +in the first form, making a list of it if it is not a list +already. If there are more forms, insert the first form as the +second item in second form, etc." + (declare (debug (form &rest [&or symbolp (sexp &rest form)]))) + (cond + ((null form) x) + ((null more) (if (listp form) + `(,(car form) ,x ,@(cdr form)) + (list form x))) + (:else `(-> (-> ,x ,form) ,@more)))) + +(defmacro ->> (x &optional form &rest more) + "Thread the expr through the forms. Insert X as the last item +in the first form, making a list of it if it is not a list +already. If there are more forms, insert the first form as the +last item in second form, etc." + (declare (debug ->)) + (cond + ((null form) x) + ((null more) (if (listp form) + `(,@form ,x) + (list form x))) + (:else `(->> (->> ,x ,form) ,@more)))) + +(defmacro --> (x &rest forms) + "Starting with the value of X, thread each expression through FORMS. + +Insert X at the position signified by the symbol `it' in the first +form. If there are more forms, insert the first form at the position +signified by `it' in the second form, etc." + (declare (debug (form body))) + `(-as-> ,x it ,@forms)) + +(defmacro -as-> (value variable &rest forms) + "Starting with VALUE, thread VARIABLE through FORMS. + +In the first form, bind VARIABLE to VALUE. In the second form, bind +VARIABLE to the result of the first form, and so forth." + (declare (debug (form symbolp body))) + (if (null forms) + `,value + `(let ((,variable ,value)) + (-as-> ,(if (symbolp (car forms)) + (list (car forms) variable) + (car forms)) + ,variable + ,@(cdr forms))))) + +(defmacro -some-> (x &optional form &rest more) + "When expr is non-nil, thread it through the first form (via `->'), +and when that result is non-nil, through the next form, etc." + (declare (debug ->) + (indent 1)) + (if (null form) x + (let ((result (make-symbol "result"))) + `(-some-> (-when-let (,result ,x) + (-> ,result ,form)) + ,@more)))) + +(defmacro -some->> (x &optional form &rest more) + "When expr is non-nil, thread it through the first form (via `->>'), +and when that result is non-nil, through the next form, etc." + (declare (debug ->) + (indent 1)) + (if (null form) x + (let ((result (make-symbol "result"))) + `(-some->> (-when-let (,result ,x) + (->> ,result ,form)) + ,@more)))) + +(defmacro -some--> (expr &rest forms) + "Thread EXPR through FORMS via `-->', while the result is non-nil. +When EXPR evaluates to non-nil, thread the result through the +first of FORMS, and when that result is non-nil, thread it +through the next form, etc." + (declare (debug (form &rest &or symbolp consp)) (indent 1)) + (if (null forms) expr + (let ((result (make-symbol "result"))) + `(-some--> (-when-let (,result ,expr) + (--> ,result ,(car forms))) + ,@(cdr forms))))) + +(defmacro -doto (init &rest forms) + "Evaluate INIT and pass it as argument to FORMS with `->'. +The RESULT of evaluating INIT is threaded through each of FORMS +individually using `->', which see. The return value is RESULT, +which FORMS may have modified by side effect." + (declare (debug (form &rest &or symbolp consp)) (indent 1)) + (let ((retval (make-symbol "result"))) + `(let ((,retval ,init)) + ,@(mapcar (lambda (form) `(-> ,retval ,form)) forms) + ,retval))) + +(defmacro --doto (init &rest forms) + "Anaphoric form of `-doto'. +This just evaluates INIT, binds the result to `it', evaluates +FORMS, and returns the final value of `it'. +Note: `it' need not be used in each form." + (declare (debug (form body)) (indent 1)) + `(let ((it ,init)) + ,@forms + it)) + +(defun -grade-up (comparator list) + "Grade elements of LIST using COMPARATOR relation. +This yields a permutation vector such that applying this +permutation to LIST sorts it in ascending order." + (declare (important-return-value t)) + (->> (--map-indexed (cons it it-index) list) + (-sort (lambda (it other) (funcall comparator (car it) (car other)))) + (mapcar #'cdr))) + +(defun -grade-down (comparator list) + "Grade elements of LIST using COMPARATOR relation. +This yields a permutation vector such that applying this +permutation to LIST sorts it in descending order." + (declare (important-return-value t)) + (->> (--map-indexed (cons it it-index) list) + (-sort (lambda (it other) (funcall comparator (car other) (car it)))) + (mapcar #'cdr))) + +(defvar dash--source-counter 0 + "Monotonic counter for generated symbols.") + +(defun dash--match-make-source-symbol () + "Generate a new dash-source symbol. + +All returned symbols are guaranteed to be unique." + (prog1 (make-symbol (format "--dash-source-%d--" dash--source-counter)) + (setq dash--source-counter (1+ dash--source-counter)))) + +(defun dash--match-ignore-place-p (symbol) + "Return non-nil if SYMBOL is a symbol and starts with _." + (and (symbolp symbol) + (eq (aref (symbol-name symbol) 0) ?_))) + +(defun dash--match-cons-skip-cdr (skip-cdr source) + "Helper function generating idiomatic shifting code." + (cond + ((= skip-cdr 0) + `(pop ,source)) + (t + `(prog1 ,(dash--match-cons-get-car skip-cdr source) + (setq ,source ,(dash--match-cons-get-cdr (1+ skip-cdr) source)))))) + +(defun dash--match-cons-get-car (skip-cdr source) + "Helper function generating idiomatic code to get nth car." + (cond + ((= skip-cdr 0) + `(car ,source)) + ((= skip-cdr 1) + `(cadr ,source)) + (t + `(nth ,skip-cdr ,source)))) + +(defun dash--match-cons-get-cdr (skip-cdr source) + "Helper function generating idiomatic code to get nth cdr." + (cond + ((= skip-cdr 0) + source) + ((= skip-cdr 1) + `(cdr ,source)) + (t + `(nthcdr ,skip-cdr ,source)))) + +(defun dash--match-cons (match-form source) + "Setup a cons matching environment and call the real matcher." + (let ((s (dash--match-make-source-symbol)) + (n 0) + (m match-form)) + (while (and (consp m) + (dash--match-ignore-place-p (car m))) + (setq n (1+ n)) (!cdr m)) + (cond + ;; when we only have one pattern in the list, we don't have to + ;; create a temporary binding (--dash-source--) for the source + ;; and just use the input directly + ((and (consp m) + (not (cdr m))) + (dash--match (car m) (dash--match-cons-get-car n source))) + ;; handle other special types + ((> n 0) + (dash--match m (dash--match-cons-get-cdr n source))) + ;; this is the only entry-point for dash--match-cons-1, that's + ;; why we can't simply use the above branch, it would produce + ;; infinite recursion + (t + (cons (list s source) (dash--match-cons-1 match-form s)))))) + +(defun dash--get-expand-function (type) + "Get expand function name for TYPE." + (intern-soft (format "dash-expand:%s" type))) + +(defun dash--match-cons-1 (match-form source &optional props) + "Match MATCH-FORM against SOURCE. + +MATCH-FORM is a proper or improper list. Each element of +MATCH-FORM is either a symbol, which gets bound to the respective +value in source or another match form which gets destructured +recursively. + +If the cdr of last cons cell in the list is nil, matching stops +there. + +SOURCE is a proper or improper list." + (let ((skip-cdr (or (plist-get props :skip-cdr) 0))) + (cond + ((consp match-form) + (cond + ((cdr match-form) + (cond + ((and (symbolp (car match-form)) + (functionp (dash--get-expand-function (car match-form)))) + (dash--match-kv (dash--match-kv-normalize-match-form match-form) (dash--match-cons-get-cdr skip-cdr source))) + ((dash--match-ignore-place-p (car match-form)) + (dash--match-cons-1 (cdr match-form) source + (plist-put props :skip-cdr (1+ skip-cdr)))) + (t + (-concat (dash--match (car match-form) (dash--match-cons-skip-cdr skip-cdr source)) + (dash--match-cons-1 (cdr match-form) source))))) + (t ;; Last matching place, no need for shift + (dash--match (car match-form) (dash--match-cons-get-car skip-cdr source))))) + ((eq match-form nil) + nil) + (t ;; Handle improper lists. Last matching place, no need for shift + (dash--match match-form (dash--match-cons-get-cdr skip-cdr source)))))) + +(defun dash--match-vector (match-form source) + "Setup a vector matching environment and call the real matcher." + (let ((s (dash--match-make-source-symbol))) + (cond + ;; don't bind `s' if we only have one sub-pattern + ((= (length match-form) 1) + (dash--match (aref match-form 0) `(aref ,source 0))) + ;; if the source is a symbol, we don't need to re-bind it + ((symbolp source) + (dash--match-vector-1 match-form source)) + ;; don't bind `s' if we only have one sub-pattern which is not ignored + ((let* ((ignored-places (mapcar 'dash--match-ignore-place-p match-form)) + (ignored-places-n (length (-remove 'null ignored-places)))) + (when (= ignored-places-n (1- (length match-form))) + (let ((n (-find-index 'null ignored-places))) + (dash--match (aref match-form n) `(aref ,source ,n)))))) + (t + (cons (list s source) (dash--match-vector-1 match-form s)))))) + +(defun dash--match-vector-1 (match-form source) + "Match MATCH-FORM against SOURCE. + +MATCH-FORM is a vector. Each element of MATCH-FORM is either a +symbol, which gets bound to the respective value in source or +another match form which gets destructured recursively. + +If second-from-last place in MATCH-FORM is the symbol &rest, the +next element of the MATCH-FORM is matched against the tail of +SOURCE, starting at index of the &rest symbol. This is +conceptually the same as the (head . tail) match for improper +lists, where dot plays the role of &rest. + +SOURCE is a vector. + +If the MATCH-FORM vector is shorter than SOURCE vector, only +the (length MATCH-FORM) places are bound, the rest of the SOURCE +is discarded." + (let ((i 0) + (l (length match-form)) + (re)) + (while (< i l) + (let ((m (aref match-form i))) + (push (cond + ((and (symbolp m) + (eq m '&rest)) + (prog1 (dash--match + (aref match-form (1+ i)) + `(substring ,source ,i)) + (setq i l))) + ((and (symbolp m) + ;; do not match symbols starting with _ + (not (eq (aref (symbol-name m) 0) ?_))) + (list (list m `(aref ,source ,i)))) + ((not (symbolp m)) + (dash--match m `(aref ,source ,i)))) + re) + (setq i (1+ i)))) + (-flatten-n 1 (nreverse re)))) + +(defun dash--match-kv-normalize-match-form (pattern) + "Normalize kv PATTERN. + +This method normalizes PATTERN to the format expected by +`dash--match-kv'. See `-let' for the specification." + (let ((normalized (list (car pattern))) + (skip nil) + (fill-placeholder (make-symbol "--dash-fill-placeholder--"))) + (-each (-zip-fill fill-placeholder (cdr pattern) (cddr pattern)) + (lambda (pair) + (let ((current (car pair)) + (next (cdr pair))) + (if skip + (setq skip nil) + (if (or (eq fill-placeholder next) + (not (or (and (symbolp next) + (not (keywordp next)) + (not (eq next t)) + (not (eq next nil))) + (and (consp next) + (not (eq (car next) 'quote))) + (vectorp next)))) + (progn + (cond + ((keywordp current) + (push current normalized) + (push (intern (substring (symbol-name current) 1)) normalized)) + ((stringp current) + (push current normalized) + (push (intern current) normalized)) + ((and (consp current) + (eq (car current) 'quote)) + (push current normalized) + (push (cadr current) normalized)) + (t (error "-let: found key `%s' in kv destructuring but its pattern `%s' is invalid and can not be derived from the key" current next))) + (setq skip nil)) + (push current normalized) + (push next normalized) + (setq skip t)))))) + (nreverse normalized))) + +(defun dash--match-kv (match-form source) + "Setup a kv matching environment and call the real matcher. + +kv can be any key-value store, such as plist, alist or hash-table." + (let ((s (dash--match-make-source-symbol))) + (cond + ;; don't bind `s' if we only have one sub-pattern (&type key val) + ((= (length match-form) 3) + (dash--match-kv-1 (cdr match-form) source (car match-form))) + ;; if the source is a symbol, we don't need to re-bind it + ((symbolp source) + (dash--match-kv-1 (cdr match-form) source (car match-form))) + (t + (cons (list s source) (dash--match-kv-1 (cdr match-form) s (car match-form))))))) + +(defun dash-expand:&hash (key source) + "Generate extracting KEY from SOURCE for &hash destructuring." + `(gethash ,key ,source)) + +(defun dash-expand:&plist (key source) + "Generate extracting KEY from SOURCE for &plist destructuring." + `(plist-get ,source ,key)) + +(defun dash-expand:&alist (key source) + "Generate extracting KEY from SOURCE for &alist destructuring." + `(cdr (assoc ,key ,source))) + +(defun dash-expand:&hash? (key source) + "Generate extracting KEY from SOURCE for &hash? destructuring. +Similar to &hash but check whether the map is not nil." + (let ((src (make-symbol "src"))) + `(let ((,src ,source)) + (when ,src (gethash ,key ,src))))) + +(defalias 'dash-expand:&keys #'dash-expand:&plist) + +(defun dash--match-kv-1 (match-form source type) + "Match MATCH-FORM against SOURCE of type TYPE. + +MATCH-FORM is a proper list of the form (key1 place1 ... keyN +placeN). Each placeK is either a symbol, which gets bound to the +value of keyK retrieved from the key-value store, or another +match form which gets destructured recursively. + +SOURCE is a key-value store of type TYPE, which can be a plist, +an alist or a hash table. + +TYPE is a token specifying the type of the key-value store. +Valid values are &plist, &alist and &hash." + (-flatten-n 1 (-map + (lambda (kv) + (let* ((k (car kv)) + (v (cadr kv)) + (getter + (funcall (dash--get-expand-function type) k source))) + (cond + ((symbolp v) + (list (list v getter))) + (t (dash--match v getter))))) + (-partition 2 match-form)))) + +(defun dash--match-symbol (match-form source) + "Bind a symbol. + +This works just like `let', there is no destructuring." + (list (list match-form source))) + +(defun dash--match (match-form source) + "Match MATCH-FORM against SOURCE. + +This function tests the MATCH-FORM and dispatches to specific +matchers based on the type of the expression. + +Key-value stores are disambiguated by placing a token &plist, +&alist or &hash as a first item in the MATCH-FORM." + (cond + ((and (symbolp match-form) + ;; Don't bind things like &keys as if they were vars (#395). + (not (functionp (dash--get-expand-function match-form)))) + (dash--match-symbol match-form source)) + ((consp match-form) + (cond + ;; Handle the "x &as" bindings first. + ((and (consp (cdr match-form)) + (symbolp (car match-form)) + (eq '&as (cadr match-form))) + (let ((s (car match-form))) + (cons (list s source) + (dash--match (cddr match-form) s)))) + ((functionp (dash--get-expand-function (car match-form))) + (dash--match-kv (dash--match-kv-normalize-match-form match-form) source)) + (t (dash--match-cons match-form source)))) + ((vectorp match-form) + ;; We support the &as binding in vectors too + (cond + ((and (> (length match-form) 2) + (symbolp (aref match-form 0)) + (eq '&as (aref match-form 1))) + (let ((s (aref match-form 0))) + (cons (list s source) + (dash--match (substring match-form 2) s)))) + (t (dash--match-vector match-form source)))))) + +(defun dash--normalize-let-varlist (varlist) + "Normalize VARLIST so that every binding is a list. + +`let' allows specifying a binding which is not a list but simply +the place which is then automatically bound to nil, such that all +three of the following are identical and evaluate to nil. + + (let (a) a) + (let ((a)) a) + (let ((a nil)) a) + +This function normalizes all of these to the last form." + (--map (if (consp it) it (list it nil)) varlist)) + +(defmacro -let* (varlist &rest body) + "Bind variables according to VARLIST then eval BODY. + +VARLIST is a list of lists of the form (PATTERN SOURCE). Each +PATTERN is matched against the SOURCE structurally. SOURCE is +only evaluated once for each PATTERN. + +Each SOURCE can refer to the symbols already bound by this +VARLIST. This is useful if you want to destructure SOURCE +recursively but also want to name the intermediate structures. + +See `-let' for the list of all possible patterns." + (declare (debug ((&rest [&or (sexp form) sexp]) body)) + (indent 1)) + (let* ((varlist (dash--normalize-let-varlist varlist)) + (bindings (--mapcat (dash--match (car it) (cadr it)) varlist))) + `(let* ,bindings + ,@body))) + +(defmacro -let (varlist &rest body) + "Bind variables according to VARLIST then eval BODY. + +VARLIST is a list of lists of the form (PATTERN SOURCE). Each +PATTERN is matched against the SOURCE \"structurally\". SOURCE +is only evaluated once for each PATTERN. Each PATTERN is matched +recursively, and can therefore contain sub-patterns which are +matched against corresponding sub-expressions of SOURCE. + +All the SOURCEs are evalled before any symbols are +bound (i.e. \"in parallel\"). + +If VARLIST only contains one (PATTERN SOURCE) element, you can +optionally specify it using a vector and discarding the +outer-most parens. Thus + + (-let ((PATTERN SOURCE)) ...) + +becomes + + (-let [PATTERN SOURCE] ...). + +`-let' uses a convention of not binding places (symbols) starting +with _ whenever it's possible. You can use this to skip over +entries you don't care about. However, this is not *always* +possible (as a result of implementation) and these symbols might +get bound to undefined values. + +Following is the overview of supported patterns. Remember that +patterns can be matched recursively, so every a, b, aK in the +following can be a matching construct and not necessarily a +symbol/variable. + +Symbol: + + a - bind the SOURCE to A. This is just like regular `let'. + +Conses and lists: + + (a) - bind `car' of cons/list to A + + (a . b) - bind car of cons to A and `cdr' to B + + (a b) - bind car of list to A and `cadr' to B + + (a1 a2 a3 ...) - bind 0th car of list to A1, 1st to A2, 2nd to A3... + + (a1 a2 a3 ... aN . rest) - as above, but bind the Nth cdr to REST. + +Vectors: + + [a] - bind 0th element of a non-list sequence to A (works with + vectors, strings, bit arrays...) + + [a1 a2 a3 ...] - bind 0th element of non-list sequence to A0, 1st to + A1, 2nd to A2, ... + If the PATTERN is shorter than SOURCE, the values at + places not in PATTERN are ignored. + If the PATTERN is longer than SOURCE, an `error' is + thrown. + + [a1 a2 a3 ... &rest rest] - as above, but bind the rest of + the sequence to REST. This is + conceptually the same as improper list + matching (a1 a2 ... aN . rest) + +Key/value stores: + + (&plist key0 a0 ... keyN aN) - bind value mapped by keyK in the + SOURCE plist to aK. If the + value is not found, aK is nil. + Uses `plist-get' to fetch values. + + (&alist key0 a0 ... keyN aN) - bind value mapped by keyK in the + SOURCE alist to aK. If the + value is not found, aK is nil. + Uses `assoc' to fetch values. + + (&hash key0 a0 ... keyN aN) - bind value mapped by keyK in the + SOURCE hash table to aK. If the + value is not found, aK is nil. + Uses `gethash' to fetch values. + +Further, special keyword &keys supports \"inline\" matching of +plist-like key-value pairs, similarly to &keys keyword of +`cl-defun'. + + (a1 a2 ... aN &keys key1 b1 ... keyN bK) + +This binds N values from the list to a1 ... aN, then interprets +the cdr as a plist (see key/value matching above). + +A shorthand notation for kv-destructuring exists which allows the +patterns be optionally left out and derived from the key name in +the following fashion: + +- a key :foo is converted into `foo' pattern, +- a key \\='bar is converted into `bar' pattern, +- a key \"baz\" is converted into `baz' pattern. + +That is, the entire value under the key is bound to the derived +variable without any further destructuring. + +This is possible only when the form following the key is not a +valid pattern (i.e. not a symbol, a cons cell or a vector). +Otherwise the matching proceeds as usual and in case of an +invalid spec fails with an error. + +Thus the patterns are normalized as follows: + + ;; derive all the missing patterns + (&plist :foo \\='bar \"baz\") => (&plist :foo foo \\='bar bar \"baz\" baz) + + ;; we can specify some but not others + (&plist :foo \\='bar explicit-bar) => (&plist :foo foo \\='bar explicit-bar) + + ;; nothing happens, we store :foo in x + (&plist :foo x) => (&plist :foo x) + + ;; nothing happens, we match recursively + (&plist :foo (a b c)) => (&plist :foo (a b c)) + +You can name the source using the syntax SYMBOL &as PATTERN. +This syntax works with lists (proper or improper), vectors and +all types of maps. + + (list &as a b c) (list 1 2 3) + +binds A to 1, B to 2, C to 3 and LIST to (1 2 3). + +Similarly: + + (bounds &as beg . end) (cons 1 2) + +binds BEG to 1, END to 2 and BOUNDS to (1 . 2). + + (items &as first . rest) (list 1 2 3) + +binds FIRST to 1, REST to (2 3) and ITEMS to (1 2 3) + + [vect &as _ b c] [1 2 3] + +binds B to 2, C to 3 and VECT to [1 2 3] (_ avoids binding as usual). + + (plist &as &plist :b b) (list :a 1 :b 2 :c 3) + +binds B to 2 and PLIST to (:a 1 :b 2 :c 3). Same for &alist and &hash. + +This is especially useful when we want to capture the result of a +computation and destructure at the same time. Consider the +form (function-returning-complex-structure) returning a list of +two vectors with two items each. We want to capture this entire +result and pass it to another computation, but at the same time +we want to get the second item from each vector. We can achieve +it with pattern + + (result &as [_ a] [_ b]) (function-returning-complex-structure) + +Note: Clojure programmers may know this feature as the \":as +binding\". The difference is that we put the &as at the front +because we need to support improper list binding." + (declare (debug ([&or (&rest [&or (sexp form) sexp]) + (vector [&rest [sexp form]])] + body)) + (indent 1)) + (if (vectorp varlist) + `(let* ,(dash--match (aref varlist 0) (aref varlist 1)) + ,@body) + (let* ((varlist (dash--normalize-let-varlist varlist)) + (inputs (--map-indexed (list (make-symbol (format "input%d" it-index)) (cadr it)) varlist)) + (new-varlist (--zip-with (list (car it) (car other)) + varlist inputs))) + `(let ,inputs + (-let* ,new-varlist ,@body))))) + +(defmacro -lambda (match-form &rest body) + "Return a lambda which destructures its input as MATCH-FORM and executes BODY. + +Note that you have to enclose the MATCH-FORM in a pair of parens, +such that: + + (-lambda (x) body) + (-lambda (x y ...) body) + +has the usual semantics of `lambda'. Furthermore, these get +translated into normal `lambda', so there is no performance +penalty. + +See `-let' for a description of the destructuring mechanism." + (declare (doc-string 2) (indent defun) + (debug (&define sexp + [&optional stringp] + [&optional ("interactive" interactive)] + def-body))) + (cond + ((nlistp match-form) + (signal 'wrong-type-argument (list #'listp match-form))) + ;; No destructuring, so just return regular `lambda' for speed. + ((-all? #'symbolp match-form) + `(lambda ,match-form ,@body)) + ((let ((inputs (--map-indexed + (list it (make-symbol (format "input%d" it-index))) + match-form))) + ;; TODO: because inputs to the `lambda' are evaluated only once, + ;; `-let*' need not create the extra bindings to ensure that. + ;; We should find a way to optimize that. Not critical however. + `(lambda ,(mapcar #'cadr inputs) + (-let* ,inputs ,@body)))))) + +(defmacro -setq (&rest forms) + "Bind each MATCH-FORM to the value of its VAL. + +MATCH-FORM destructuring is done according to the rules of `-let'. + +This macro allows you to bind multiple variables by destructuring +the value, so for example: + + (-setq (a b) x + (&plist :c c) plist) + +expands roughly speaking to the following code + + (setq a (car x) + b (cadr x) + c (plist-get plist :c)) + +Care is taken to only evaluate each VAL once so that in case of +multiple assignments it does not cause unexpected side effects. + +\(fn [MATCH-FORM VAL]...)" + (declare (debug (&rest sexp form)) + (indent 1)) + (when (= (mod (length forms) 2) 1) + (signal 'wrong-number-of-arguments (list '-setq (1+ (length forms))))) + (let* ((forms-and-sources + ;; First get all the necessary mappings with all the + ;; intermediate bindings. + (-map (lambda (x) (dash--match (car x) (cadr x))) + (-partition 2 forms))) + ;; To preserve the logic of dynamic scoping we must ensure + ;; that we `setq' the variables outside of the `let*' form + ;; which holds the destructured intermediate values. For + ;; this we generate for each variable a placeholder which is + ;; bound to (lexically) the result of the destructuring. + ;; Then outside of the helper `let*' form we bind all the + ;; original variables to their respective placeholders. + ;; TODO: There is a lot of room for possible optimization, + ;; for start playing with `special-variable-p' to eliminate + ;; unnecessary re-binding. + (variables-to-placeholders + (-mapcat + (lambda (bindings) + (-map + (lambda (binding) + (let ((var (car binding))) + (list var (make-symbol (concat "--dash-binding-" (symbol-name var) "--"))))) + (--filter (not (string-prefix-p "--" (symbol-name (car it)))) bindings))) + forms-and-sources))) + `(let ,(-map 'cadr variables-to-placeholders) + (let* ,(-flatten-n 1 forms-and-sources) + (setq ,@(-flatten (-map 'reverse variables-to-placeholders)))) + (setq ,@(-flatten variables-to-placeholders))))) + +(defmacro -if-let* (vars-vals then &rest else) + "If all VALS evaluate to true, bind them to their corresponding +VARS and do THEN, otherwise do ELSE. VARS-VALS should be a list +of (VAR VAL) pairs. + +Note: binding is done according to `-let*'. VALS are evaluated +sequentially, and evaluation stops after the first nil VAL is +encountered." + (declare (debug ((&rest (sexp form)) form body)) + (indent 2)) + (->> vars-vals + (--mapcat (dash--match (car it) (cadr it))) + (--reduce-r-from + (let ((var (car it)) + (val (cadr it))) + `(let ((,var ,val)) + (if ,var ,acc ,@else))) + then))) + +(defmacro -if-let (var-val then &rest else) + "If VAL evaluates to non-nil, bind it to VAR and do THEN, +otherwise do ELSE. + +Note: binding is done according to `-let'. + +\(fn (VAR VAL) THEN &rest ELSE)" + (declare (debug ((sexp form) form body)) + (indent 2)) + `(-if-let* (,var-val) ,then ,@else)) + +(defmacro --if-let (val then &rest else) + "If VAL evaluates to non-nil, bind it to symbol `it' and do THEN, +otherwise do ELSE." + (declare (debug (form form body)) + (indent 2)) + `(-if-let (it ,val) ,then ,@else)) + +(defmacro -when-let* (vars-vals &rest body) + "If all VALS evaluate to true, bind them to their corresponding +VARS and execute body. VARS-VALS should be a list of (VAR VAL) +pairs. + +Note: binding is done according to `-let*'. VALS are evaluated +sequentially, and evaluation stops after the first nil VAL is +encountered." + (declare (debug ((&rest (sexp form)) body)) + (indent 1)) + `(-if-let* ,vars-vals (progn ,@body))) + +(defmacro -when-let (var-val &rest body) + "If VAL evaluates to non-nil, bind it to VAR and execute body. + +Note: binding is done according to `-let'. + +\(fn (VAR VAL) &rest BODY)" + (declare (debug ((sexp form) body)) + (indent 1)) + `(-if-let ,var-val (progn ,@body))) + +(defmacro --when-let (val &rest body) + "If VAL evaluates to non-nil, bind it to symbol `it' and +execute body." + (declare (debug (form body)) + (indent 1)) + `(--if-let ,val (progn ,@body))) + +;; TODO: Get rid of this dynamic variable, passing it as an argument +;; instead? +(defvar -compare-fn nil + "Tests for equality use this function, or `equal' if this is nil. + +As a dynamic variable, this should be temporarily bound around +the relevant operation, rather than permanently modified. For +example: + + (let ((-compare-fn #\\='=)) + (-union \\='(1 2 3) \\='(2 3 4)))") + +(defun dash--member-fn () + "Return the flavor of `member' that goes best with `-compare-fn'." + (declare (side-effect-free error-free)) + (let ((cmp -compare-fn)) + (cond ((memq cmp '(nil equal)) #'member) + ((eq cmp #'eq) #'memq) + ((eq cmp #'eql) #'memql) + ((lambda (elt list) + (while (and list (not (funcall cmp elt (car list)))) + (pop list)) + list))))) + +(defun dash--assoc-fn () + "Return the flavor of `assoc' that goes best with `-compare-fn'." + (declare (side-effect-free error-free)) + (let ((cmp -compare-fn)) + (cond ((memq cmp '(nil equal)) #'assoc) + ((eq cmp #'eq) #'assq) + ((lambda (key alist) + ;; Since Emacs 26, `assoc' accepts a custom `testfn'. + ;; Version testing would be simpler here, but feature + ;; testing gets more brownie points, I guess. + (static-if (condition-case nil + (assoc nil () #'eql) + (wrong-number-of-arguments t)) + (--first (and (consp it) (funcall cmp (car it) key)) alist) + (assoc key alist cmp))))))) + +(defun dash--hash-test-fn () + "Return the hash table test function corresponding to `-compare-fn'. +Return nil if `-compare-fn' is not a known test function." + (declare (side-effect-free error-free)) + ;; In theory this could also recognize values that are custom + ;; `hash-table-test's, but too often the :test name is different + ;; from the equality function, so it doesn't seem worthwhile. + (car (memq (or -compare-fn #'equal) '(equal eq eql)))) + +(defvar dash--short-list-length 32 + "Maximum list length considered short, for optimizations. +For example, the speedup afforded by hash table lookup may start +to outweigh its runtime and memory overhead for problem sizes +greater than this value. See also the discussion in PR #305.") + +(defun -distinct (list) + "Return a copy of LIST with all duplicate elements removed. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil. + +Alias: `-uniq'." + (declare (important-return-value t)) + (let (test len) + (cond ((null list) ()) + ;; Use a hash table if `-compare-fn' is a known hash table + ;; test function and the list is long enough. + ((and (setq test (dash--hash-test-fn)) + (> (setq len (length list)) dash--short-list-length)) + (let ((ht (make-hash-table :test test :size len))) + (--filter (unless (gethash it ht) (puthash it t ht)) list))) + ((let ((member (dash--member-fn)) uniq) + (--each list (unless (funcall member it uniq) (push it uniq))) + (nreverse uniq)))))) + +(defalias '-uniq #'-distinct) + +(defun dash--size+ (size1 size2) + "Return the sum of nonnegative fixnums SIZE1 and SIZE2. +Return `most-positive-fixnum' on overflow. This ensures the +result is a valid size, particularly for allocating hash tables, +even in the presence of bignum support." + (declare (side-effect-free t)) + (if (< size1 (- most-positive-fixnum size2)) + (+ size1 size2) + most-positive-fixnum)) + +(defun -union (list1 list2) + "Return a new list of distinct elements appearing in either LIST1 or LIST2. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil." + (declare (important-return-value t)) + (let ((lists (list list1 list2)) test len union) + (cond ((null (or list1 list2))) + ;; Use a hash table if `-compare-fn' is a known hash table + ;; test function and the lists are long enough. + ((and (setq test (dash--hash-test-fn)) + (> (setq len (dash--size+ (length list1) (length list2))) + dash--short-list-length)) + (let ((ht (make-hash-table :test test :size len))) + (dolist (l lists) + (--each l (unless (gethash it ht) + (puthash it t ht) + (push it union)))))) + ((let ((member (dash--member-fn))) + (dolist (l lists) + (--each l (unless (funcall member it union) (push it union))))))) + (nreverse union))) + +(defun -intersection (list1 list2) + "Return a new list of distinct elements appearing in both LIST1 and LIST2. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil." + (declare (important-return-value t)) + (let (test len) + (cond ((null (and list1 list2)) ()) + ;; Use a hash table if `-compare-fn' is a known hash table + ;; test function and either list is long enough. + ((and (setq test (dash--hash-test-fn)) + (> (setq len (length list2)) dash--short-list-length)) + (let ((ht (make-hash-table :test test :size len))) + (--each list2 (puthash it t ht)) + ;; Remove visited elements to avoid duplicates. + (--filter (when (gethash it ht) (remhash it ht) t) list1))) + ((let ((member (dash--member-fn)) intersection) + (--each list1 (and (funcall member it list2) + (not (funcall member it intersection)) + (push it intersection))) + (nreverse intersection)))))) + +(defun -difference (list1 list2) + "Return a new list with the distinct members of LIST1 that are not in LIST2. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil." + (declare (important-return-value t)) + (let (test len1 len2) + (cond ((null list1) ()) + ((null list2) (-distinct list1)) + ;; Use a hash table if `-compare-fn' is a known hash table + ;; test function and the subtrahend is long enough. + ((and (setq test (dash--hash-test-fn)) + (setq len1 (length list1)) + (setq len2 (length list2)) + (> (max len1 len2) dash--short-list-length)) + (let ((ht1 (make-hash-table :test test :size len1)) + (ht2 (make-hash-table :test test :size len2))) + (--each list2 (puthash it t ht2)) + ;; Avoid duplicates by tracking visited items in `ht1'. + (--filter (unless (or (gethash it ht2) (gethash it ht1)) + (puthash it t ht1)) + list1))) + ((let ((member (dash--member-fn)) difference) + (--each list1 + (unless (or (funcall member it list2) + (funcall member it difference)) + (push it difference))) + (nreverse difference)))))) + +(defun -powerset (list) + "Return the power set of LIST." + (declare (pure t) (side-effect-free t)) + (if (null list) (list ()) + (let ((last (-powerset (cdr list)))) + (nconc (mapcar (lambda (x) (cons (car list) x)) last) + last)))) + +(defun -frequencies (list) + "Count the occurrences of each distinct element of LIST. + +Return an alist of (ELEMENT . N), where each ELEMENT occurs N +times in LIST. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil. + +See also `-count' and `-group-by'." + (declare (important-return-value t)) + (let (test len freqs) + (cond ((null list)) + ((and (setq test (dash--hash-test-fn)) + (> (setq len (length list)) dash--short-list-length)) + (let ((ht (make-hash-table :test test :size len))) + ;; Share structure between hash table and returned list. + ;; This affords a single pass that preserves the input + ;; order, conses less garbage, and is faster than a + ;; second traversal (e.g., with `maphash'). + (--each list + (let ((freq (gethash it ht))) + (if freq + (setcdr freq (1+ (cdr freq))) + (push (puthash it (cons it 1) ht) freqs)))))) + ((let ((assoc (dash--assoc-fn))) + (--each list + (let ((freq (funcall assoc it freqs))) + (if freq + (setcdr freq (1+ (cdr freq))) + (push (cons it 1) freqs))))))) + (nreverse freqs))) + +(defun dash--numbers<= (nums) + "Return non-nil if NUMS is a list of non-decreasing numbers." + (declare (pure t) (side-effect-free t)) + (or (null nums) + (let ((prev (pop nums))) + (and (numberp prev) + (--every (and (numberp it) (<= prev (setq prev it))) nums))))) + +(defun dash--next-lex-perm (array n) + "Update ARRAY of N numbers with its next lexicographic permutation. +Return nil if there is no such successor. N should be nonzero. + +This implements the salient steps of Algorithm L (Lexicographic +permutation generation) as described in DE Knuth's The Art of +Computer Programming, Volume 4A / Combinatorial Algorithms, +Part I, Addison-Wesley, 2011, § 7.2.1.2, p. 319." + (setq n (1- n)) + (let* ((l n) + (j (1- n)) + (al (aref array n)) + (aj al)) + ;; L2. [Find j]. + ;; Decrement j until a[j] < a[j+1]. + (while (and (<= 0 j) + (<= aj (setq aj (aref array j)))) + (setq j (1- j))) + ;; Terminate algorithm if j not found. + (when (>= j 0) + ;; L3. [Increase a[j]]. + ;; Decrement l until a[j] < a[l]. + (while (>= aj al) + (setq l (1- l) al (aref array l))) + ;; Swap a[j] and a[l]. + (aset array j al) + (aset array l aj) + ;; L4. [Reverse a[j+1]...a[n]]. + (setq l n) + (while (< (setq j (1+ j)) l) + (setq aj (aref array j)) + (aset array j (aref array l)) + (aset array l aj) + (setq l (1- l))) + array))) + +(defun dash--lex-perms (vec &optional original) + "Return a list of permutations of VEC in lexicographic order. +Specifically, return only the successors of VEC in lexicographic +order. Each returned permutation is a list. VEC should comprise +one or more numbers, and may be destructively modified. + +If ORIGINAL is a vector, then VEC is interpreted as a set of +indices into ORIGINAL. In this case, the indices are permuted, +and the resulting index permutations are used to dereference +elements of ORIGINAL." + (let ((len (length vec)) perms) + (while vec + (push (if original + (--map (aref original it) vec) + (append vec ())) + perms) + (setq vec (dash--next-lex-perm vec len))) + (nreverse perms))) + +(defun dash--uniq-perms (list) + "Return a list of permutations of LIST. +LIST is treated as if all its elements are distinct." + (let* ((vec (vconcat list)) + (idxs (copy-sequence vec))) + ;; Just construct a vector of the list's indices and permute that. + (dotimes (i (length idxs)) + (aset idxs i i)) + (dash--lex-perms idxs vec))) + +(defun dash--multi-perms (list freqs) + "Return a list of permutations of the multiset LIST. +FREQS should be an alist describing the frequency of each element +in LIST, as returned by `-frequencies'." + (let (;; Distinct items in `list', aka the cars of `freqs'. + (uniq (make-vector (length freqs) nil)) + ;; Indices into `uniq'. + (idxs (make-vector (length list) nil)) + ;; Current index into `idxs'. + (i 0)) + (--each freqs + (aset uniq it-index (car it)) + ;; Populate `idxs' with as many copies of each `it-index' as + ;; there are corresponding duplicates. + (dotimes (_ (cdr it)) + (aset idxs i it-index) + (setq i (1+ i)))) + (dash--lex-perms idxs uniq))) + +(defun -permutations (list) + "Return the distinct permutations of LIST. + +Duplicate elements of LIST are determined by `equal', or by +`-compare-fn' if that is non-nil." + (declare (important-return-value t)) + (cond ((null list) (list ())) + ;; Optimization: a traversal of `list' is faster than the + ;; round trip via `dash--uniq-perms' or `dash--multi-perms'. + ((dash--numbers<= list) + (dash--lex-perms (vconcat list))) + ((let ((freqs (-frequencies list))) + ;; Is each element distinct? + (unless (--every (= (cdr it) 1) freqs) + (dash--multi-perms list freqs)))) + ((dash--uniq-perms list)))) + +(defun -inits (list) + "Return all prefixes of LIST." + (declare (pure t) (side-effect-free t)) + (let ((res (list list))) + (setq list (reverse list)) + (while list + (push (reverse (!cdr list)) res)) + res)) + +(defun -tails (list) + "Return all suffixes of LIST." + (declare (pure t) (side-effect-free t)) + (-reductions-r-from #'cons nil list)) + +(defun -common-prefix (&rest lists) + "Return the longest common prefix of LISTS." + (declare (pure t) (side-effect-free t)) + (--reduce (--take-while (and acc (equal (pop acc) it)) it) + lists)) + +(defun -common-suffix (&rest lists) + "Return the longest common suffix of LISTS." + (declare (pure t) (side-effect-free t)) + (nreverse (apply #'-common-prefix (mapcar #'reverse lists)))) + +(defun -contains? (list element) + "Return non-nil if LIST contains ELEMENT. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil. As with `member', the return value is +actually the tail of LIST whose car is ELEMENT. + +Alias: `-contains-p'." + (declare (important-return-value t)) + (funcall (dash--member-fn) element list)) + +(defalias '-contains-p #'-contains?) + +(defun -same-items? (list1 list2) + "Return non-nil if LIST1 and LIST2 have the same distinct elements. + +The order of the elements in the lists does not matter. The +lists may be of different lengths, i.e., contain duplicate +elements. The test for equality is done with `equal', or with +`-compare-fn' if that is non-nil. + +Alias: `-same-items-p'." + (declare (important-return-value t)) + (let (test len1 len2) + (cond ((null (or list1 list2))) + ((null (and list1 list2)) nil) + ;; Use a hash table if `-compare-fn' is a known hash table + ;; test function and either list is long enough. + ((and (setq test (dash--hash-test-fn)) + (setq len1 (length list1)) + (setq len2 (length list2)) + (> (max len1 len2) dash--short-list-length)) + (let ((ht1 (make-hash-table :test test :size len1)) + (ht2 (make-hash-table :test test :size len2))) + (--each list1 (puthash it t ht1)) + ;; Move visited elements from `ht1' to `ht2'. This way, + ;; if visiting all of `list2' leaves `ht1' empty, then + ;; all elements from both lists have been accounted for. + (and (--every (cond ((gethash it ht1) + (remhash it ht1) + (puthash it t ht2)) + ((gethash it ht2))) + list2) + (zerop (hash-table-count ht1))))) + ((let ((member (dash--member-fn))) + (and (--all? (funcall member it list2) list1) + (--all? (funcall member it list1) list2))))))) + +(defalias '-same-items-p #'-same-items?) + +(defun -is-prefix? (prefix list) + "Return non-nil if PREFIX is a prefix of LIST. + +Alias: `-is-prefix-p'." + (declare (pure t) (side-effect-free t)) + (--each-while list (and (equal (car prefix) it) + (!cdr prefix))) + (null prefix)) + +(defun -is-suffix? (suffix list) + "Return non-nil if SUFFIX is a suffix of LIST. + +Alias: `-is-suffix-p'." + (declare (pure t) (side-effect-free t)) + (equal suffix (last list (length suffix)))) + +(defun -is-infix? (infix list) + "Return non-nil if INFIX is infix of LIST. + +This operation runs in O(n^2) time + +Alias: `-is-infix-p'" + (declare (pure t) (side-effect-free t)) + (let (done) + (while (and (not done) list) + (setq done (-is-prefix? infix list)) + (!cdr list)) + done)) + +(defalias '-is-prefix-p '-is-prefix?) +(defalias '-is-suffix-p '-is-suffix?) +(defalias '-is-infix-p '-is-infix?) + +(defun -sort (comparator list) + "Sort LIST, stably, comparing elements using COMPARATOR. +Return the sorted list. LIST is NOT modified by side effects. +COMPARATOR is called with two elements of LIST, and should return non-nil +if the first element should sort before the second." + (declare (important-return-value t)) + (static-if (condition-case nil (sort []) (wrong-number-of-arguments)) + ;; Since Emacs 30. + (sort list :lessp comparator) + (sort (copy-sequence list) comparator))) + +(defmacro --sort (form list) + "Anaphoric form of `-sort'." + (declare (debug (def-form form))) + `(-sort (lambda (it other) (ignore it other) ,form) ,list)) + +(defun -list (&optional arg &rest args) + "Ensure ARG is a list. +If ARG is already a list, return it as is (not a copy). +Otherwise, return a new list with ARG as its only element. + +Another supported calling convention is (-list &rest ARGS). +In this case, if ARG is not a list, a new list with all of +ARGS as elements is returned. This use is supported for +backward compatibility and is otherwise deprecated." + (declare (advertised-calling-convention (arg) "2.18.0") + (pure t) (side-effect-free error-free)) + (if (listp arg) arg (cons arg args))) + +(defun -repeat (n x) + "Return a new list of length N with each element being X. +Return nil if N is less than 1." + (declare (side-effect-free t)) + (and (>= n 0) (make-list n x))) + +(defun -sum (list) + "Return the sum of LIST." + (declare (pure t) (side-effect-free t)) + (apply #'+ list)) + +(defun -running-sum (list) + "Return a list with running sums of items in LIST. +LIST must be non-empty." + (declare (pure t) (side-effect-free t)) + (or list (signal 'wrong-type-argument (list #'consp list))) + (-reductions #'+ list)) + +(defun -product (list) + "Return the product of LIST." + (declare (pure t) (side-effect-free t)) + (apply #'* list)) + +(defun -running-product (list) + "Return a list with running products of items in LIST. +LIST must be non-empty." + (declare (pure t) (side-effect-free t)) + (or list (signal 'wrong-type-argument (list #'consp list))) + (-reductions #'* list)) + +(defun -max (list) + "Return the largest value from LIST of numbers or markers." + (declare (pure t) (side-effect-free t)) + (apply #'max list)) + +(defun -min (list) + "Return the smallest value from LIST of numbers or markers." + (declare (pure t) (side-effect-free t)) + (apply #'min list)) + +(defun -max-by (comparator list) + "Take a comparison function COMPARATOR and a LIST and return +the greatest element of the list by the comparison function. + +See also combinator `-on' which can transform the values before +comparing them." + (declare (important-return-value t)) + (--reduce (if (funcall comparator it acc) it acc) list)) + +(defun -min-by (comparator list) + "Take a comparison function COMPARATOR and a LIST and return +the least element of the list by the comparison function. + +See also combinator `-on' which can transform the values before +comparing them." + (declare (important-return-value t)) + (--reduce (if (funcall comparator it acc) acc it) list)) + +(defmacro --max-by (form list) + "Anaphoric version of `-max-by'. + +The items for the comparator form are exposed as \"it\" and \"other\"." + (declare (debug (def-form form))) + `(-max-by (lambda (it other) (ignore it other) ,form) ,list)) + +(defmacro --min-by (form list) + "Anaphoric version of `-min-by'. + +The items for the comparator form are exposed as \"it\" and \"other\"." + (declare (debug (def-form form))) + `(-min-by (lambda (it other) (ignore it other) ,form) ,list)) + +(defun -iota (count &optional start step) + "Return a list containing COUNT numbers. +Starts from START and adds STEP each time. The default START is +zero, the default STEP is 1. +This function takes its name from the corresponding primitive in +the APL language." + (declare (side-effect-free t)) + (unless (natnump count) + (signal 'wrong-type-argument (list #'natnump count))) + (or start (setq start 0)) + (or step (setq step 1)) + (if (zerop step) + (make-list count start) + (--iterate (+ it step) start count))) + +(defun -fix (fn list) + "Compute the (least) fixpoint of FN with initial input LIST. + +FN is called at least once, results are compared with `equal'." + (declare (important-return-value t)) + (let ((re (funcall fn list))) + (while (not (equal list re)) + (setq list re) + (setq re (funcall fn re))) + re)) + +(defmacro --fix (form list) + "Anaphoric form of `-fix'." + (declare (debug (def-form form))) + `(-fix (lambda (it) (ignore it) ,form) ,list)) + +(defun -unfold (fun seed) + "Build a list from SEED using FUN. + +This is \"dual\" operation to `-reduce-r': while -reduce-r +consumes a list to produce a single value, `-unfold' takes a +seed value and builds a (potentially infinite!) list. + +FUN should return nil to stop the generating process, or a +cons (A . B), where A will be prepended to the result and B is +the new seed." + (declare (important-return-value t)) + (let ((last (funcall fun seed)) r) + (while last + (push (car last) r) + (setq last (funcall fun (cdr last)))) + (nreverse r))) + +(defmacro --unfold (form seed) + "Anaphoric version of `-unfold'." + (declare (debug (def-form form))) + `(-unfold (lambda (it) (ignore it) ,form) ,seed)) + +(defun -cons-pair? (obj) + "Return non-nil if OBJ is a true cons pair. +That is, a cons (A . B) where B is not a list. + +Alias: `-cons-pair-p'." + (declare (pure t) (side-effect-free error-free)) + (nlistp (cdr-safe obj))) + +(defalias '-cons-pair-p '-cons-pair?) + +(defun -cons-to-list (con) + "Convert a cons pair to a list with `car' and `cdr' of the pair respectively." + (declare (pure t) (side-effect-free t)) + (list (car con) (cdr con))) + +(defun -value-to-list (val) + "Convert a value to a list. + +If the value is a cons pair, make a list with two elements, `car' +and `cdr' of the pair respectively. + +If the value is anything else, wrap it in a list." + (declare (pure t) (side-effect-free t)) + (if (-cons-pair? val) (-cons-to-list val) (list val))) + +(defun -tree-mapreduce-from (fn folder init-value tree) + "Apply FN to each element of TREE, and make a list of the results. +If elements of TREE are lists themselves, apply FN recursively to +elements of these nested lists. + +Then reduce the resulting lists using FOLDER and initial value +INIT-VALUE. See `-reduce-r-from'. + +This is the same as calling `-tree-reduce-from' after `-tree-map' +but is twice as fast as it only traverse the structure once." + (declare (important-return-value t)) + (cond + ((null tree) ()) + ((-cons-pair? tree) (funcall fn tree)) + ((consp tree) + (-reduce-r-from + folder init-value + (mapcar (lambda (x) (-tree-mapreduce-from fn folder init-value x)) tree))) + ((funcall fn tree)))) + +(defmacro --tree-mapreduce-from (form folder init-value tree) + "Anaphoric form of `-tree-mapreduce-from'." + (declare (debug (def-form def-form form form))) + `(-tree-mapreduce-from (lambda (it) (ignore it) ,form) + (lambda (it acc) (ignore it acc) ,folder) + ,init-value + ,tree)) + +(defun -tree-mapreduce (fn folder tree) + "Apply FN to each element of TREE, and make a list of the results. +If elements of TREE are lists themselves, apply FN recursively to +elements of these nested lists. + +Then reduce the resulting lists using FOLDER and initial value +INIT-VALUE. See `-reduce-r-from'. + +This is the same as calling `-tree-reduce' after `-tree-map' +but is twice as fast as it only traverse the structure once." + (declare (important-return-value t)) + (cond + ((null tree) ()) + ((-cons-pair? tree) (funcall fn tree)) + ((consp tree) + (-reduce-r folder (mapcar (lambda (x) (-tree-mapreduce fn folder x)) tree))) + ((funcall fn tree)))) + +(defmacro --tree-mapreduce (form folder tree) + "Anaphoric form of `-tree-mapreduce'." + (declare (debug (def-form def-form form))) + `(-tree-mapreduce (lambda (it) (ignore it) ,form) + (lambda (it acc) (ignore it acc) ,folder) + ,tree)) + +(defun -tree-map (fn tree) + "Apply FN to each element of TREE while preserving the tree structure." + (declare (important-return-value t)) + (cond + ((null tree) ()) + ((-cons-pair? tree) (funcall fn tree)) + ((consp tree) + (mapcar (lambda (x) (-tree-map fn x)) tree)) + ((funcall fn tree)))) + +(defmacro --tree-map (form tree) + "Anaphoric form of `-tree-map'." + (declare (debug (def-form form))) + `(-tree-map (lambda (it) (ignore it) ,form) ,tree)) + +(defun -tree-reduce-from (fn init-value tree) + "Use FN to reduce elements of list TREE. +If elements of TREE are lists themselves, apply the reduction recursively. + +FN is first applied to INIT-VALUE and first element of the list, +then on this result and second element from the list etc. + +The initial value is ignored on cons pairs as they always contain +two elements." + (declare (important-return-value t)) + (cond + ((null tree) ()) + ((-cons-pair? tree) tree) + ((consp tree) + (-reduce-r-from + fn init-value + (mapcar (lambda (x) (-tree-reduce-from fn init-value x)) tree))) + (tree))) + +(defmacro --tree-reduce-from (form init-value tree) + "Anaphoric form of `-tree-reduce-from'." + (declare (debug (def-form form form))) + `(-tree-reduce-from (lambda (it acc) (ignore it acc) ,form) + ,init-value ,tree)) + +(defun -tree-reduce (fn tree) + "Use FN to reduce elements of list TREE. +If elements of TREE are lists themselves, apply the reduction recursively. + +FN is first applied to first element of the list and second +element, then on this result and third element from the list etc. + +See `-reduce-r' for how exactly are lists of zero or one element handled." + (declare (important-return-value t)) + (cond + ((null tree) ()) + ((-cons-pair? tree) tree) + ((consp tree) + (-reduce-r fn (mapcar (lambda (x) (-tree-reduce fn x)) tree))) + (tree))) + +(defmacro --tree-reduce (form tree) + "Anaphoric form of `-tree-reduce'." + (declare (debug (def-form form))) + `(-tree-reduce (lambda (it acc) (ignore it acc) ,form) ,tree)) + +(defun -tree-map-nodes (pred fun tree) + "Call FUN on each node of TREE that satisfies PRED. + +If PRED returns nil, continue descending down this node. If PRED +returns non-nil, apply FUN to this node and do not descend +further." + (cond ((funcall pred tree) (funcall fun tree)) + ((and (listp tree) (listp (cdr tree))) + (-map (lambda (x) (-tree-map-nodes pred fun x)) tree)) + (tree))) + +(defmacro --tree-map-nodes (pred form tree) + "Anaphoric form of `-tree-map-nodes'." + (declare (debug (def-form def-form form))) + `(-tree-map-nodes (lambda (it) (ignore it) ,pred) + (lambda (it) (ignore it) ,form) + ,tree)) + +(defun -tree-seq (branch children tree) + "Return a sequence of the nodes in TREE, in depth-first search order. + +BRANCH is a predicate of one argument that returns non-nil if the +passed argument is a branch, that is, a node that can have children. + +CHILDREN is a function of one argument that returns the children +of the passed branch node. + +Non-branch nodes are simply copied." + (declare (important-return-value t)) + (cons tree + (and (funcall branch tree) + (-mapcat (lambda (x) (-tree-seq branch children x)) + (funcall children tree))))) + +(defmacro --tree-seq (branch children tree) + "Anaphoric form of `-tree-seq'." + (declare (debug (def-form def-form form))) + `(-tree-seq (lambda (it) (ignore it) ,branch) + (lambda (it) (ignore it) ,children) + ,tree)) + +(defun -clone (list) + "Create a deep copy of LIST. +The new list has the same elements and structure but all cons are +replaced with new ones. This is useful when you need to clone a +structure such as plist or alist." + (declare (side-effect-free t)) + (-tree-map #'identity list)) + +;;; Combinators + +(defalias '-partial #'apply-partially + "Return a function that is a partial application of FUN to ARGS. +ARGS is a list of the first N arguments to pass to FUN. +The result is a new function which does the same as FUN, except that +the first N arguments are fixed at the values with which this function +was called. +\n(fn FUN &rest ARGS)") + +(defun -rpartial (fn &rest args) + "Return a function that is a partial application of FN to ARGS. +ARGS is a list of the last N arguments to pass to FN. The result +is a new function which does the same as FN, except that the last +N arguments are fixed at the values with which this function was +called. This is like `-partial', except the arguments are fixed +starting from the right rather than the left." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args-before) (apply fn (append args-before args)))) + +(defun -juxt (&rest fns) + "Return a function that is the juxtaposition of FNS. +The returned function takes a variable number of ARGS, applies +each of FNS in turn to ARGS, and returns the list of results." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args) (mapcar (lambda (x) (apply x args)) fns))) + +(defun -compose (&rest fns) + "Compose FNS into a single composite function. +Return a function that takes a variable number of ARGS, applies +the last function in FNS to ARGS, and returns the result of +calling each remaining function on the result of the previous +function, right-to-left. If no FNS are given, return a variadic +`identity' function." + (declare (pure t) (side-effect-free error-free)) + (let* ((fns (nreverse fns)) + (head (car fns)) + (tail (cdr fns))) + (cond (tail + (lambda (&rest args) + (--reduce-from (funcall it acc) (apply head args) tail))) + (fns head) + ((lambda (&optional arg &rest _) arg))))) + +(defun -applify (fn) + "Return a function that applies FN to a single list of args. +This changes the arity of FN from taking N distinct arguments to +taking 1 argument which is a list of N arguments." + (declare (pure t) (side-effect-free error-free)) + (lambda (args) (apply fn args))) + +(defun -on (op trans) + "Return a function that calls TRANS on each arg and OP on the results. +The returned function takes a variable number of arguments, calls +the function TRANS on each one in turn, and then passes those +results as the list of arguments to OP, in the same order. + +For example, the following pairs of expressions are morally +equivalent: + + (funcall (-on #\\='+ #\\='1+) 1 2 3) = (+ (1+ 1) (1+ 2) (1+ 3)) + (funcall (-on #\\='+ #\\='1+)) = (+)" + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args) + ;; This unrolling seems to be a relatively cheap way to keep the + ;; overhead of `mapcar' + `apply' in check. + (cond ((cddr args) + (apply op (mapcar trans args))) + ((cdr args) + (funcall op (funcall trans (car args)) (funcall trans (cadr args)))) + (args + (funcall op (funcall trans (car args)))) + ((funcall op))))) + +(defun -flip (fn) + "Return a function that calls FN with its arguments reversed. +The returned function takes the same number of arguments as FN. + +For example, the following two expressions are morally +equivalent: + + (funcall (-flip #\\='-) 1 2) = (- 2 1) + +See also: `-rotate-args'." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args) ;; Open-code for speed. + (cond ((cddr args) (apply fn (nreverse args))) + ((cdr args) (funcall fn (cadr args) (car args))) + (args (funcall fn (car args))) + ((funcall fn))))) + +(defun -rotate-args (n fn) + "Return a function that calls FN with args rotated N places to the right. +The returned function takes the same number of arguments as FN, +rotates the list of arguments N places to the right (left if N is +negative) just like `-rotate', and applies FN to the result. + +See also: `-flip'." + (declare (pure t) (side-effect-free t)) + (if (zerop n) + fn + (let ((even (= (% n 2) 0))) + (lambda (&rest args) + (cond ((cddr args) ;; Open-code for speed. + (apply fn (-rotate n args))) + ((cdr args) + (let ((fst (car args)) + (snd (cadr args))) + (funcall fn (if even fst snd) (if even snd fst)))) + (args + (funcall fn (car args))) + ((funcall fn))))))) + +(defun -const (c) + "Return a function that returns C ignoring any additional arguments. + +In types: a -> b -> a" + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest _) c)) + +(defmacro -cut (&rest params) + "Take n-ary function and n arguments and specialize some of them. +Arguments denoted by <> will be left unspecialized. + +See SRFI-26 for detailed description." + (declare (debug (&optional sexp &rest &or "<>" form))) + (let* ((i 0) + (args (--keep (when (eq it '<>) + (setq i (1+ i)) + (make-symbol (format "D%d" i))) + params))) + `(lambda ,args + ,(let ((body (--map (if (eq it '<>) (pop args) it) params))) + (if (eq (car params) '<>) + (cons #'funcall body) + body))))) + +(defun -not (pred) + "Return a predicate that negates the result of PRED. +The returned predicate passes its arguments to PRED. If PRED +returns nil, the result is non-nil; otherwise the result is nil. + +See also: `-andfn' and `-orfn'." + (declare (pure t) (side-effect-free error-free)) + (lambda (&rest args) (not (apply pred args)))) + +(defun -orfn (&rest preds) + "Return a predicate that returns the first non-nil result of PREDS. +The returned predicate takes a variable number of arguments, +passes them to each predicate in PREDS in turn until one of them +returns non-nil, and returns that non-nil result without calling +the remaining PREDS. If all PREDS return nil, or if no PREDS are +given, the returned predicate returns nil. + +See also: `-andfn' and `-not'." + (declare (pure t) (side-effect-free error-free)) + ;; Open-code for speed. + (cond ((cdr preds) (lambda (&rest args) (--some (apply it args) preds))) + (preds (car preds)) + (#'ignore))) + +(defun -andfn (&rest preds) + "Return a predicate that returns non-nil if all PREDS do so. +The returned predicate P takes a variable number of arguments and +passes them to each predicate in PREDS in turn. If any one of +PREDS returns nil, P also returns nil without calling the +remaining PREDS. If all PREDS return non-nil, P returns the last +such value. If no PREDS are given, P always returns non-nil. + +See also: `-orfn' and `-not'." + (declare (pure t) (side-effect-free error-free)) + ;; Open-code for speed. + (cond ((cdr preds) (lambda (&rest args) (--every (apply it args) preds))) + (preds (car preds)) + ((static-if (fboundp 'always) + #'always + (lambda (&rest _) t))))) + +(defun -iteratefn (fn n) + "Return a function FN composed N times with itself. + +FN is a unary function. If you need to use a function of higher +arity, use `-applify' first to turn it into a unary function. + +With n = 0, this acts as identity function. + +In types: (a -> a) -> Int -> a -> a. + +This function satisfies the following law: + + (funcall (-iteratefn fn n) init) = (-last-item (-iterate fn init (1+ n)))." + (declare (pure t) (side-effect-free error-free)) + (lambda (x) (--dotimes n (setq x (funcall fn x))) x)) + +(defun -counter (&optional beg end inc) + "Return a closure that counts from BEG to END, with increment INC. + +The closure will return the next value in the counting sequence +each time it is called, and nil after END is reached. BEG +defaults to 0, INC defaults to 1, and if END is nil, the counter +will increment indefinitely. + +The closure accepts any number of arguments, which are discarded." + (declare (pure t) (side-effect-free error-free)) + (let ((inc (or inc 1)) + (n (or beg 0))) + (lambda (&rest _) + (when (or (not end) (< n end)) + (prog1 n + (setq n (+ n inc))))))) + +(defvar -fixfn-max-iterations 1000 + "The default maximum number of iterations performed by `-fixfn' + unless otherwise specified.") + +(defun -fixfn (fn &optional equal-test halt-test) + "Return a function that computes the (least) fixpoint of FN. + +FN must be a unary function. The returned lambda takes a single +argument, X, the initial value for the fixpoint iteration. The +iteration halts when either of the following conditions is satisfied: + + 1. Iteration converges to the fixpoint, with equality being + tested using EQUAL-TEST. If EQUAL-TEST is not specified, + `equal' is used. For functions over the floating point + numbers, it may be necessary to provide an appropriate + approximate comparison test. + + 2. HALT-TEST returns a non-nil value. HALT-TEST defaults to a + simple counter that returns t after `-fixfn-max-iterations', + to guard against infinite iteration. Otherwise, HALT-TEST + must be a function that accepts a single argument, the + current value of X, and returns non-nil as long as iteration + should continue. In this way, a more sophisticated + convergence test may be supplied by the caller. + +The return value of the lambda is either the fixpoint or, if +iteration halted before converging, a cons with car `halted' and +cdr the final output from HALT-TEST. + +In types: (a -> a) -> a -> a." + (declare (important-return-value t)) + (let ((eqfn (or equal-test 'equal)) + (haltfn (or halt-test + (-not + (-counter 0 -fixfn-max-iterations))))) + (lambda (x) + (let ((re (funcall fn x)) + (halt? (funcall haltfn x))) + (while (and (not halt?) (not (funcall eqfn x re))) + (setq x re + re (funcall fn re) + halt? (funcall haltfn re))) + (if halt? (cons 'halted halt?) + re))))) + +(defun -prodfn (&rest fns) + "Return a function that applies each of FNS to each of a list of arguments. + +Takes a list of N functions and returns a function that takes a +list of length N, applying Ith function to Ith element of the +input list. Returns a list of length N. + +In types (for N=2): ((a -> b), (c -> d)) -> (a, c) -> (b, d) + +This function satisfies the following laws: + + (-compose (-prodfn f g ...) + (-prodfn f\\=' g\\=' ...)) + = (-prodfn (-compose f f\\=') + (-compose g g\\=') + ...) + + (-prodfn f g ...) + = (-juxt (-compose f (-partial #\\='nth 0)) + (-compose g (-partial #\\='nth 1)) + ...) + + (-compose (-prodfn f g ...) + (-juxt f\\=' g\\=' ...)) + = (-juxt (-compose f f\\=') + (-compose g g\\=') + ...) + + (-compose (-partial #\\='nth n) + (-prod f1 f2 ...)) + = (-compose fn (-partial #\\='nth n))" + (declare (pure t) (side-effect-free t)) + (lambda (x) (--zip-with (funcall it other) fns x))) + +;;; Font lock + +(defvar dash--keywords + `(;; TODO: Do not fontify the following automatic variables + ;; globally; detect and limit to their local anaphoric scope. + (,(rx symbol-start (| "acc" "it" "it-index" "other") symbol-end) + . 'font-lock-variable-name-face) + ;; Macros in dev/examples.el. Based on `lisp-mode-symbol-regexp'. + (,(rx ?\( (group (| "defexamples" "def-example-group")) symbol-end + (+ (in "\t ")) + (group (* (| (syntax word) (syntax symbol) (: ?\\ nonl))))) + (1 'font-lock-keyword-face) + (2 'font-lock-function-name-face)) + ;; Symbols in dev/examples.el. + ,(rx symbol-start (| "=>" "~>" "!!>") symbol-end) + ;; Elisp macro fontification was static prior to Emacs 25. + ,@(when (< emacs-major-version 25) + (let ((macs '("!cdr" + "!cons" + "-->" + "--all-p" + "--all?" + "--annotate" + "--any" + "--any-p" + "--any?" + "--count" + "--dotimes" + "--doto" + "--drop-while" + "--each" + "--each-indexed" + "--each-r" + "--each-r-while" + "--each-while" + "--every" + "--every-p" + "--every?" + "--filter" + "--find" + "--find-index" + "--find-indices" + "--find-last-index" + "--first" + "--fix" + "--group-by" + "--if-let" + "--iterate" + "--keep" + "--last" + "--map" + "--map-first" + "--map-indexed" + "--map-last" + "--map-when" + "--mapcat" + "--max-by" + "--min-by" + "--none-p" + "--none?" + "--only-some-p" + "--only-some?" + "--partition-after-pred" + "--partition-by" + "--partition-by-header" + "--reduce" + "--reduce-from" + "--reduce-r" + "--reduce-r-from" + "--reductions" + "--reductions-from" + "--reductions-r" + "--reductions-r-from" + "--reject" + "--reject-first" + "--reject-last" + "--remove" + "--remove-first" + "--remove-last" + "--replace-where" + "--select" + "--separate" + "--some" + "--some-p" + "--some?" + "--sort" + "--splice" + "--splice-list" + "--split-when" + "--split-with" + "--take-while" + "--tree-map" + "--tree-map-nodes" + "--tree-mapreduce" + "--tree-mapreduce-from" + "--tree-reduce" + "--tree-reduce-from" + "--tree-seq" + "--unfold" + "--update-at" + "--when-let" + "--zip-with" + "->" + "->>" + "-as->" + "-cut" + "-doto" + "-if-let" + "-if-let*" + "-lambda" + "-let" + "-let*" + "-setq" + "-some-->" + "-some->" + "-some->>" + "-split-on" + "-when-let" + "-when-let*"))) + `((,(concat "(" (regexp-opt macs 'symbols)) . 1))))) + "Font lock keywords for `dash-fontify-mode'.") + +(defcustom dash-fontify-mode-lighter nil + "Mode line lighter for `dash-fontify-mode'. +Either a string to display in the mode line when +`dash-fontify-mode' is on, or nil to display +nothing (the default)." + :package-version '(dash . "2.18.0") + :type '(choice (string :tag "Lighter" :value " Dash") + (const :tag "Nothing" nil))) + +;;;###autoload +(define-minor-mode dash-fontify-mode + "Toggle fontification of Dash special variables. + +Dash-Fontify mode is a buffer-local minor mode intended for Emacs +Lisp buffers. Enabling it causes the special variables bound in +anaphoric Dash macros to be fontified. These anaphoras include +`it', `it-index', `acc', and `other'. In older Emacs versions +which do not dynamically detect macros, Dash-Fontify mode +additionally fontifies Dash macro calls. + +See also `dash-fontify-mode-lighter' and +`global-dash-fontify-mode'." + :lighter dash-fontify-mode-lighter + (if dash-fontify-mode + (font-lock-add-keywords nil dash--keywords t) + (font-lock-remove-keywords nil dash--keywords)) + (static-if (fboundp 'font-lock-flush) + ;; Added in Emacs 25. + (font-lock-flush) + (when font-lock-mode + ;; Unconditionally enables `font-lock-mode' and is marked + ;; `interactive-only' in later Emacs versions which have + ;; `font-lock-flush'. + (font-lock-fontify-buffer)))) + +(defun dash--turn-on-fontify-mode () + "Enable `dash-fontify-mode' if in an Emacs Lisp buffer." + (when (derived-mode-p #'emacs-lisp-mode) + (dash-fontify-mode))) + +;;;###autoload +(define-globalized-minor-mode global-dash-fontify-mode + dash-fontify-mode dash--turn-on-fontify-mode) + +(defcustom dash-enable-fontlock nil + "If non-nil, fontify Dash macro calls and special variables." + :set (lambda (sym val) + (set-default sym val) + (global-dash-fontify-mode (if val 1 0))) + :type 'boolean) + +(make-obsolete-variable + 'dash-enable-fontlock #'global-dash-fontify-mode "2.18.0") + +(define-obsolete-function-alias + 'dash-enable-font-lock #'global-dash-fontify-mode "2.18.0") + +;;; Info + +(defvar dash--info-doc-spec '("(dash) Index" nil "^ -+ .*: " "\\( \\|$\\)") + "The Dash :doc-spec entry for `info-lookup-alist'. +It is based on that for `emacs-lisp-mode'.") + +(defun dash--info-elisp-docs () + "Return the `emacs-lisp-mode' symbol docs from `info-lookup-alist'. +Specifically, return the cons containing their +`info-lookup->doc-spec' so that we can modify it." + (defvar info-lookup-alist) + (nthcdr 3 (assq #'emacs-lisp-mode (cdr (assq 'symbol info-lookup-alist))))) + +;;;###autoload +(defun dash-register-info-lookup () + "Register the Dash Info manual with `info-lookup-symbol'. +This allows Dash symbols to be looked up with \\[info-lookup-symbol]." + (interactive) + (require 'info-look) + (let ((docs (dash--info-elisp-docs))) + (setcar docs (append (car docs) (list dash--info-doc-spec))) + (info-lookup-reset))) + +(defun dash-unload-function () + "Remove Dash from `info-lookup-alist'. +Used by `unload-feature', which see." + (let ((docs (and (featurep 'info-look) + (dash--info-elisp-docs)))) + (when (member dash--info-doc-spec (car docs)) + (setcar docs (remove dash--info-doc-spec (car docs))) + (info-lookup-reset))) + nil) + +(provide 'dash) +;;; dash.el ends here diff --git a/.emacs.d/lisp/dumb-jump.el b/.emacs.d/lisp/dumb-jump.el new file mode 100644 index 0000000..7606645 --- /dev/null +++ b/.emacs.d/lisp/dumb-jump.el @@ -0,0 +1,3331 @@ +;;; dumb-jump.el --- Jump to definition for 50+ languages without configuration -*- lexical-binding: t; -*- +;; Copyright (C) 2015-2021 jack angers +;; Author: jack angers and contributors +;; Url: https://github.com/jacktasia/dumb-jump +;; Version: 0.5.4 +;; Package-Requires: ((emacs "24.3") (s "1.11.0") (dash "2.9.0") (popup "0.5.3")) +;; Keywords: programming + +;; Dumb Jump is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; Dumb Jump 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 Dumb Jump. If not, see http://www.gnu.org/licenses. + +;;; Commentary: + +;; Dumb Jump is an Emacs "jump to definition" package with support for 50+ programming languages that favors +;; "just working" over speed or accuracy. This means minimal -- and ideally zero -- configuration with absolutely +;; no stored indexes (TAGS) or persistent background processes. +;; +;; Dumb Jump provides a xref-based interface for jumping to +;; definitions. It is based on tools such as grep, the silver searcher +;; (https://geoff.greer.fm/ag/), ripgrep +;; (https://github.com/BurntSushi/ripgrep) or git-grep +;; (https://git-scm.com/docs/git-grep). +;; +;; To enable Dumb Jump, add the following to your initialisation file: +;; +;; (add-hook 'xref-backend-functions #'dumb-jump-xref-activate) +;; +;; Now pressing M-. on an identifier should open a buffer at the place +;; where it is defined, or a list of candidates if uncertain. This +;; list can be navigated using M-g M-n (next-error) and M-g M-p +;; (previous-error). + +;;; Code: +(unless (require 'xref nil :noerror) + (require 'etags)) +(require 's) +(require 'dash) +(require 'popup) +(require 'cl-generic nil :noerror) +(require 'cl-lib) + +(defgroup dumb-jump nil + "Easily jump to project function and variable definitions" + :group 'tools + :group 'convenience) + +;;;###autoload +(defvar dumb-jump-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-M-g") 'dumb-jump-go) + (define-key map (kbd "C-M-p") 'dumb-jump-back) + (define-key map (kbd "C-M-q") 'dumb-jump-quick-look) + map)) + +(defcustom dumb-jump-window + 'current + "Which window to use when jumping. Valid options are 'current (default) or 'other." + :group 'dumb-jump + :type '(choice (const :tag "Current window" current) + (const :tag "Other window" other))) + +(defcustom dumb-jump-use-visible-window + t + "When true will jump in a visible window if that window already has the file open." + :group 'dumb-jump + :type 'boolean) + +(defcustom dumb-jump-selector + 'popup + "Which selector to use when there is multiple choices. `ivy` and `helm' are also supported." + :group 'dumb-jump + :type '(choice (const :tag "Popup" popup) + (const :tag "Helm" helm) + (const :tag "Ivy" ivy) + (const :tag "Completing Read" completing-read))) + +(defcustom dumb-jump-ivy-jump-to-selected-function + #'dumb-jump-ivy-jump-to-selected + "Prompts user for a choice using ivy then dumb-jump to that choice." + :group 'dumb-jump + :type 'function) + +(defcustom dumb-jump-prefer-searcher + nil + "The preferred searcher to use 'ag, 'rg, 'git-grep, 'gnu-grep,or 'grep. +If nil then the most optimal searcher will be chosen at runtime." + :group 'dumb-jump + :type '(choice (const :tag "Best Available" nil) + (const :tag "ag" ag) + (const :tag "rg" rg) + (const :tag "grep" gnu-grep) + (const :tag "git grep" git-grep) + (const :tag "git grep + ag" git-grep-plus-ag))) + +(defcustom dumb-jump-force-searcher + nil + "Forcibly use searcher: 'ag, 'rg, 'git-grep, 'gnu-grep, or 'grep. +Set to nil to not force anything and use `dumb-jump-prefer-searcher' +or most optimal searcher." + :group 'dumb-jump + :type '(choice (const :tag "Best Available" nil) + (const :tag "ag" ag) + (const :tag "rg" rg) + (const :tag "grep" gnu-grep) + (const :tag "git grep" git-grep) + (const :tag "git grep + ag" git-grep-plus-ag))) + +(defcustom dumb-jump-grep-prefix + "LANG=C" + "Prefix to grep command. Seemingly makes it faster for pure text." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-grep-cmd + "grep" + "The path to grep. By default assumes it is in path." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-ag-cmd + "ag" + "The the path to the silver searcher. By default assumes it is in path. If not found fallbacks to grep." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-rg-cmd + "rg" + "The the path to ripgrep. By default assumes it is in path. If not found fallbacks to grep." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-git-grep-cmd + "git grep" + "The the path to git grep. By default assumes it is in path. If not found fallbacks to grep." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-ag-word-boundary + "(?![a-zA-Z0-9\\?\\*-])" + "`\\b` thinks `-` is a word boundary. When this matters use `\\j` instead and ag will use this value." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-rg-word-boundary + "($|[^a-zA-Z0-9\\?\\*-])" + "`\\b` thinks `-` is a word boundary. When this matters use `\\j` instead and rg will use this value." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-git-grep-word-boundary + "($|[^a-zA-Z0-9\\?\\*-])" + "`\\b` thinks `-` is a word boundary. When this matters use `\\j` instead and git grep will use this value." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-grep-word-boundary + "($|[^a-zA-Z0-9\\?\\*-])" + "`\\b` thinks `-` is a word boundary. When this matters use `\\j` instead and grep will use this value." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-fallback-regex + "\\bJJJ\\j" + "When dumb-jump-fallback-search is t use this regex. Defaults to boundary search of symbol under point." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-fallback-search + t + "If nothing is found with normal search fallback to searching the fallback regex." + :group 'dumb-jump + :type 'boolean) + +(defcustom dumb-jump-force-grep + nil + "When t will use grep even if ag is available." + :group 'dumb-jump + :type 'boolean) + +(defcustom dumb-jump-zgrep-cmd + "zgrep" + "The path to grep to use for gzipped files. By default assumes it is in path." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-grep-args "-REn" + "Grep command args [R]ecursive, [E]xtended regexes, and show line [n]umbers." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-gnu-grep-args "-rEn" + "Grep command args [r]ecursive and [E]xtended regexes, and show line [n]umbers." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-max-find-time + 2 + "Number of seconds a grep/find command can take before being warned to use ag and config." + :group 'dumb-jump + :type 'integer) + +(defcustom dumb-jump-functions-only + nil + "Should we only jump to functions?" + :group 'dumb-jump + :type 'boolean) + +(defcustom dumb-jump-quiet + nil + "If non-nil Dumb Jump will not log anything to *Messages*." + :group 'dumb-jump + :type 'boolean) + +(defcustom dumb-jump-ignore-context + nil + "If non-nil Dumb Jump will ignore the context of point when jumping." + :group 'dumb-jump + :type 'boolean) + +(defcustom dumb-jump-git-grep-search-untracked + t + "If non-nil Dumb Jump will also search untracked files when using searcher git-grep." + :group 'dumb-jump + :type 'boolean) + +(defcustom dumb-jump-git-grep-search-args + "" + "Appends the passed arguments to the git-grep search function. Default: \"\"" + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-ag-search-args + "" + "Appends the passed arguments to the ag search function. Default: \"\"" + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-rg-search-args + "--pcre2" + "Appends the passed arguments to the rg search function. Default: \"--pcre2\"" + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-search-type-org-only-org + t + "If non nil restrict type ag/rg to org file. +If nil add also the language type of current src block" + :group 'dumb-jump + :type 'boolean) + +(defcustom dumb-jump-find-rules + '((:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "elisp" + :regex "\\\((defun|cl-defun)\\s+JJJ\\j" + ;; \\j usage see `dumb-jump-ag-word-boundary` + :tests ("(defun test (blah)" "(defun test\n" "(cl-defun test (blah)" "(cl-defun test\n") + :not ("(defun test-asdf (blah)" "(defun test-blah\n" "(cl-defun test-asdf (blah)" + "(cl-defun test-blah\n" "(defun tester (blah)" "(defun test? (blah)" "(defun test- (blah)")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "elisp" + :regex "\\\(defmacro\\s+JJJ\\j" + :tests ("(defmacro test (blah)" "(defmacro test\n") + :not ("(defmacro test-asdf (blah)" "(defmacro test-blah\n" "(defmacro tester (blah)" + "(defmacro test? (blah)" "(defmacro test- (blah)")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "elisp" + :regex "\\\(defvar\\b\\s*JJJ\\j" + :tests ("(defvar test " "(defvar test\n") + :not ("(defvar tester" "(defvar test?" "(defvar test-")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "elisp" + :regex "\\\(defcustom\\b\\s*JJJ\\j" + :tests ("(defcustom test " "(defcustom test\n") + :not ("(defcustom tester" "(defcustom test?" "(defcustom test-")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "elisp" + :regex "\\\(setq\\b\\s*JJJ\\j" :tests ("(setq test 123)") + :not ("setq test-blah 123)" "(setq tester" "(setq test?" "(setq test-")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "elisp" + :regex "\\\(JJJ\\s+" :tests ("(let ((test 123)))") :not ("(let ((test-2 123)))")) + + ;; variable in method signature + (:type "variable" :supports ("ag" "rg" "git-grep") :language "elisp" + :regex "\\((defun|cl-defun)\\s*.+\\\(?\\s*JJJ\\j\\s*\\\)?" + :tests ("(defun blah (test)" "(defun blah (test blah)" "(defun (blah test)") + :not ("(defun blah (test-1)" "(defun blah (test-2 blah)" "(defun (blah test-3)")) + + ;; common lisp + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "commonlisp" + :regex "\\\(def(un|macro|generic|method|setf)\\s+JJJ\\j" + ;; \\j usage see `dumb-jump-ag-word-boundary` + :tests ("(defun test (blah)" "(defun test\n" + "(defmacro test (blah)" "(defmacro test\n" + "(defgeneric test (blah)" "(defgeneric test\n" + "(defmethod test (blah)" "(defmethod test\n" + "(defsetf test (blah)" "(defsetf test\n") + :not ("(defun test-asdf (blah)" "(defun test-blah\n" + "(defun tester (blah)" "(defun test? (blah)" "(defun test- (blah)" + "(defmacro test-asdf (blah)" "(defmacro test-blah\n" + "(defmacro tester (blah)" "(defmacro test? (blah)" "(defmacro test- (blah)" + "(defgeneric test-asdf (blah)" "(defgeneric test-blah\n" + "(defgeneric tester (blah)" "(defgeneric test? (blah)" "(defun test- (blah)" + "(defmethod test-asdf (blah)" "(defmethod test-blah\n" + "(defmethod tester (blah)" "(defmethod test? (blah)" "(defun test- (blah)" + "(defsetf test-asdf (blah)" "(defsetf test-blah\n" + "(defsetf tester (blah)" "(defsetf test? (blah)" "(defun test- (blah)")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "commonlisp" + :regex "\\\(define-(modify-macro|compiler-macro|setf-expander)\\s+JJJ\\j" + ;; \\j usage see `dumb-jump-ag-word-boundary` + :tests ("(define-modify-macro test (blah)" "(define-modify-macro test\n" + "(define-compiler-macro test (blah)" "(define-compiler-macro test\n") + :not ("(define-modify-macro test-asdf (blah)" "(define-modify-macro test-blah\n" + "(define-modify-macro tester (blah)" "(define-modify-macro test? (blah)" "(define-modify-macro test- (blah)" + "(define-compiler-macro test-asdf (blah)" "(define-compiler-macro test-blah\n" + "(define-compiler-macro tester (blah)" "(define-compiler-macro test? (blah)" "(define-compiler-macro test- (blah)")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "commonlisp" + :regex "\\\(def(var|parameter|constant)\\b\\s*JJJ\\j" + :tests ("(defvar test " "(defvar test\n" + "(defparameter test " "(defparameter test\n" + "(defconstant test " "(defconstant test\n") + :not ("(defvar tester" "(defvar test?" "(defvar test-" + "(defparameter tester" "(defparameter test?" "(defparameter test-" + "(defconstant tester" "(defconstant test?" "(defconstant test-")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "commonlisp" + :regex "\\\(define-symbol-macro\\b\\s*JJJ\\j" + :tests ("(define-symbol-macro test " "(define-symbol-macro test\n") + :not ("(define-symbol-macro tester" "(define-symbol-macro test?" "(define-symbol-macro test-")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "commonlisp" + :regex "\\\(def(class|struct|type)\\b\\s*JJJ\\j" + :tests ("(defclass test " "(defclass test\n" + "(defstruct test " "(defstruct test\n" + "(deftype test " "(deftype test\n") + :not ("(defclass tester" "(defclass test?" "(defclass test-" + "(defstruct tester" "(defstruct test?" "(defstruct test-" + "(deftype tester" "(deftype test?" "(deftype test-")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "commonlisp" + :regex "\\\(define-condition\\b\\s*JJJ\\j" + :tests ("(define-condition test " "(define-condition test\n") + :not ("(define-condition tester" "(define-condition test?" "(define-condition test-")) + + ;; racket + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "racket" + :regex "\\\(define\\s+\\(\\s*JJJ\\j" + :tests ("(define (test blah)" "(define (test\n") + :not ("(define test blah" "(define (test-asdf blah)" "(define test (lambda (blah")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "racket" + :regex "\\\(define\\s+JJJ\\s*\\\(\\s*lambda" + :tests ("(define test (lambda (blah" "(define test (lambda\n") + :not ("(define test blah" "(define test-asdf (lambda (blah)" "(define (test)" "(define (test blah) (lambda (foo")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "racket" + :regex "\\\(let\\s+JJJ\\s*(\\\(|\\\[)*" + :tests ("(let test ((blah foo) (bar bas))" "(let test\n" "(let test [(foo") + :not ("(let ((test blah")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "racket" + :regex "\\\(define\\s+JJJ\\j" + :tests ("(define test " "(define test\n") + :not ("(define (test")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "racket" + :regex "(\\\(|\\\[)\\s*JJJ\\s+" + :tests ("(let ((test 'foo" "(let [(test 'foo" "(let [(test 'foo" "(let [[test 'foo" "(let ((blah 'foo) (test 'bar)") + :not ("{test foo")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "racket" + :regex "\\\(lambda\\s+\\\(?[^\(\)]*\\s*JJJ\\j\\s*\\\)?" + :tests ("(lambda (test)" "(lambda (foo test)" "(lambda test (foo)") + :not ("(lambda () test")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "racket" + :regex "\\\(define\\s+\\\([^\(\)]+\\s*JJJ\\j\\s*\\\)?" + :tests ("(define (foo test)" "(define (foo test bar)") + :not ("(define foo test" "(define (test foo" "(define (test)")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "racket" + :regex "\\(struct\\s+JJJ\\j" + :tests ("(struct test (a b)")) + + ;; scheme + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "scheme" + :regex "\\\(define\\s+\\(\\s*JJJ\\j" + :tests ("(define (test blah)" "(define (test\n") + :not ("(define test blah" "(define (test-asdf blah)" "(define test (lambda (blah")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "scheme" + :regex "\\\(define\\s+JJJ\\s*\\\(\\s*lambda" + :tests ("(define test (lambda (blah" "(define test (lambda\n") + :not ("(define test blah" "(define test-asdf (lambda (blah)" "(define (test)" "(define (test blah) (lambda (foo")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "scheme" + :regex "\\\(let\\s+JJJ\\s*(\\\(|\\\[)*" + :tests ("(let test ((blah foo) (bar bas))" "(let test\n" "(let test [(foo") + :not ("(let ((test blah")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "scheme" + :regex "\\\(define\\s+JJJ\\j" + :tests ("(define test " "(define test\n") + :not ("(define (test")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "scheme" + :regex "(\\\(|\\\[)\\s*JJJ\\s+" + :tests ("(let ((test 'foo" "(let [(test 'foo" "(let [(test 'foo" "(let [[test 'foo" "(let ((blah 'foo) (test 'bar)") + :not ("{test foo")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "scheme" + :regex "\\\(lambda\\s+\\\(?[^\(\)]*\\s*JJJ\\j\\s*\\\)?" + :tests ("(lambda (test)" "(lambda (foo test)" "(lambda test (foo)") + :not ("(lambda () test")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "scheme" + :regex "\\\(define\\s+\\\([^\(\)]+\\s*JJJ\\j\\s*\\\)?" + :tests ("(define (foo test)" "(define (foo test bar)") + :not ("(define foo test" "(define (test foo" "(define (test)")) + + ;; janet + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "janet" + :regex "\\(\(de\)?f\\s+JJJ\\j" + :tests ("(def test (foo)")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "janet" + :regex "\\(var\\s+JJJ\\j" + :tests ("(var test (foo)")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "janet" + :regex "\\(\(de\)fn-?\\s+JJJ\\j" + :tests ("(defn test [foo]" "(defn- test [foo]") + :not ("(defn test? [foo]" "(defn- test? [foo]")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "janet" + :regex "\\(defmacro\\s+JJJ\\j" + :tests ("(defmacro test [foo]")) + + ;; c++ + (:type "function" :supports ("ag" "rg" "git-grep") :language "c++" + :regex "\\bJJJ(\\s|\\))*\\((\\w|[,&*.<>:]|\\s)*(\\))\\s*(const|->|\\{|$)|typedef\\s+(\\w|[(*]|\\s)+JJJ(\\)|\\s)*\\(" + :tests ("int test(){" "my_struct (*test)(int a, int b){" "auto MyClass::test ( Builder::Builder& reference, ) -> decltype( builder.func() ) {" "int test( int *random_argument) const {" "test::test() {" "typedef int (*test)(int);") + :not ("return test();)" "int test(a, b);" "if( test() ) {" "else test();")) + + ;; (:type "variable" :supports ("grep") :language "c++" + ;; :regex "(\\b\\w+|[,>])([*&]|\\s)+JJJ\\s*(\\[([0-9]|\\s)*\\])*\\s*([=,){;]|:\\s*[0-9])|#define\\s+JJJ\\b" + ;; :tests ("int test=2;" "char *test;" "int x = 1, test = 2" "int test[20];" "#define test" "unsigned int test:2;")) + + (:type "variable" :supports ("ag" "rg") :language "c++" + :regex "\\b(?!(class\\b|struct\\b|return\\b|else\\b|delete\\b))(\\w+|[,>])([*&]|\\s)+JJJ\\s*(\\[(\\d|\\s)*\\])*\\s*([=,(){;]|:\\s*\\d)|#define\\s+JJJ\\b" + :tests ("int test=2;" "char *test;" "int x = 1, test = 2" "int test[20];" "#define test" "typedef int test;" "unsigned int test:2") + :not ("return test;" "#define NOT test" "else test=2;")) + + (:type "type" :supports ("ag" "rg" "git-grep") :language "c++" + :regex "\\b(class|struct|enum|union)\\b\\s*JJJ\\b\\s*(final\\s*)?(:((\\s*\\w+\\s*::)*\\s*\\w*\\s*?\\s*,*)+)?((\\{|$))|}\\s*JJJ\\b\\s*;" + :tests ("typedef struct test {" "enum test {" "} test;" "union test {" "class test final: public Parent1, private Parent2{" "class test : public std::vector {") + :not("union test var;" "struct test function() {")) + + ;; clojure + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "clojure" + :regex "\\(def.*\ JJJ\\j" + :tests ("(def test (foo)" + "(defn test [foo]" + "(defn ^:some-data test [foo]" + "(defn- test [foo]" + "(defmacro test [foo]" + "(deftask test [foo]" + "(deftype test [foo]" + "(defmulti test fn" + "(defmethod test type" + "(definterface test (foo)" + "(defprotocol test (foo)" + "(defrecord test [foo]" + "(deftest test")) + + ;; coffeescript + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "coffeescript" + :regex "^\\s*JJJ\\s*[=:].*[-=]>" + :tests ("test = () =>" "test= =>" "test = ->" "test=()->" + "test : () =>" "test: =>" "test : ->" "test:()->") + :not ("# test = =>" "test = 1")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "coffeescript" + :regex "^\\s*JJJ\\s*[:=][^:=-][^>]+$" + :tests ("test = $" "test : [" "test = {" "test = a") + :not ("test::a" "test: =>" "test == 1" "# test = 1")) + + (:type "class" :supports ("ag" "grep" "rg" "git-grep") :language "coffeescript" + :regex "^\\s*\\bclass\\s+JJJ" + :tests ("class test" "class test extends") + :not ("# class")) + + ;; obj-c + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "objc" + :regex "\\\)\\s*JJJ(:|\\b|\\s)" + :tests ("- (void)test" "- (void)test:(UIAlertView *)alertView") + :not ("- (void)testnot" "- (void)testnot:(UIAlertView *)alertView")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "objc" + :regex "\\b\\*?JJJ\\s*=[^=\\n]+" + :tests ("NSString *test = @\"asdf\"") + :not ("NSString *testnot = @\"asdf\"" "NSString *nottest = @\"asdf\"")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "objc" + :regex "(@interface|@protocol|@implementation)\\b\\s*JJJ\\b\\s*" + :tests ("@interface test: UIWindow") + :not ("@interface testnon: UIWindow")) + + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "objc" + :regex "typedef\\b\\s+(NS_OPTIONS|NS_ENUM)\\b\\([^,]+?,\\s*JJJ\\b\\s*" + :tests ("typedef NS_ENUM(NSUInteger, test)") + :not ("typedef NS_ENUMD(NSUInteger, test)")) + + ;; swift + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "swift" + :regex "(let|var)\\s*JJJ\\s*(=|:)[^=:\\n]+" + :tests ("let test = 1234" "var test = 1234" "private lazy var test: UITapGestureRecognizer") + :not ("if test == 1234:")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "swift" + :regex "func\\s+JJJ\\b\\s*(<[^>]*>)?\\s*\\(" + :tests ("func test(asdf)" "func test()" "func test()") + :not ("func testnot(asdf)" "func testnot()")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "swift" + :regex "(class|struct|protocol|enum)\\s+JJJ\\b\\s*?" + :tests ("struct test" "struct test: Codable" "struct test" + "class test:" "class test: UIWindow" "class test") + :not ("class testnot:" "class testnot(object):" "struct testnot(object)")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "swift" + :regex "(typealias)\\s+JJJ\\b\\s*?=" + :tests ("typealias test =") + :not ("typealias testnot")) + + ;; c# + (:type "function" :supports ("ag" "rg") :language "csharp" + :regex "^\\s*(?:[\\w\\[\\]]+\\s+){1,3}JJJ\\s*\\\(" + :tests ("int test()" "int test(param)" "static int test()" "static int test(param)" + "public static MyType test()" "private virtual SomeType test(param)" "static int test()") + :not ("test()" "testnot()" "blah = new test()")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "csharp" + :regex "\\s*\\bJJJ\\s*=[^=\\n)]+" :tests ("int test = 1234") :not ("if test == 1234:" "int nottest = 44")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "csharp" + :regex "(class|interface)\\s*JJJ\\b" + :tests ("class test:" "public class test : IReadableChannel, I") + :not ("class testnot:" "public class testnot : IReadableChannel, I")) + + ;; java (literally the same regexes as c#, but different tests) + (:type "function" :supports ("ag" "rg") :language "java" + :regex "^\\s*(?:[\\w\\[\\]]+\\s+){1,3}JJJ\\s*\\\(" + :tests ("int test()" "int test(param)" "static int test()" "static int test(param)" + "public static MyType test()" "private virtual SomeType test(param)" "static int test()" + "private foo[] test()") + :not ("test()" "testnot()" "blah = new test()" "foo bar = test()")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "java" + :regex "\\s*\\bJJJ\\s*=[^=\\n)]+" :tests ("int test = 1234") :not ("if test == 1234:" "int nottest = 44")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "java" + :regex "(class|interface)\\s*JJJ\\b" + :tests ("class test:" "public class test implements Something") + :not ("class testnot:" "public class testnot implements Something")) + + ;; vala (again just like c#, exactly the same..) + (:type "function" :supports ("ag" "rg") :language "vala" + :regex "^\\s*(?:[\\w\\[\\]]+\\s+){1,3}JJJ\\s*\\\(" + :tests ("int test()" "int test(param)" "static int test()" "static int test(param)" + "public static MyType test()" "private virtual SomeType test(param)" "static int test()") + :not ("test()" "testnot()" "blah = new test()")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "vala" + :regex "\\s*\\bJJJ\\s*=[^=\\n)]+" :tests ("int test = 1234") :not ("if test == 1234:" "int nottest = 44")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "vala" + :regex "(class|interface)\\s*JJJ\\b" + :tests ("class test:" "public class test : IReadableChannel, I") + :not ("class testnot:" "public class testnot : IReadableChannel, I")) + + ;; coq + (:type "function" :supports ("ag" "rg" "git-grep") :language "coq" + :regex "\\s*Variable\\s+JJJ\\b" + :tests ("Variable test") + :not ("Variable testx")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "coq" + :regex "\\s*Inductive\\s+JJJ\\b" + :tests ("Inductive test") + :not ("Inductive testx")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "coq" + :regex "\\s*Lemma\\s+JJJ\\b" + :tests ("Lemma test") + :not ("Lemma testx")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "coq" + :regex "\\s*Definition\\s+JJJ\\b" + :tests ("Definition test") + :not ("Definition testx")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "coq" + :regex "\\s*Hypothesis\\s+JJJ\\b" + :tests ("Hypothesis test") + :not ("Hypothesis testx")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "coq" + :regex "\\s*Theorm\\s+JJJ\\b" + :tests ("Theorm test") + :not ("Theorm testx")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "coq" + :regex "\\s*Fixpoint\\s+JJJ\\b" + :tests ("Fixpoint test") + :not ("Fixpoint testx")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "coq" + :regex "\\s*Module\\s+JJJ\\b" + :tests ("Module test") + :not ("Module testx")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "coq" + :regex "\\s*CoInductive\\s+JJJ\\b" + :tests ("CoInductive test") + :not ("CoInductive testx")) + + ;; python + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "python" + :regex "\\s*\\bJJJ\\s*=[^=\\n]+" + :tests ("test = 1234") + :not ("if test == 1234:" "_test = 1234")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "python" + :regex "def\\s*JJJ\\b\\s*\\\(" + :tests ("\tdef test(asdf)" "def test()") + :not ("\tdef testnot(asdf)" "def testnot()")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "python" + :regex "class\\s*JJJ\\b\\s*\\\(?" + :tests ("class test(object):" "class test:") + :not ("class testnot:" "class testnot(object):")) + + ;; matlab + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "matlab" + :regex "^\\s*\\bJJJ\\s*=[^=\\n]+" + :tests ("test = 1234") + :not ("for test = 1:2:" "_test = 1234")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "matlab" + :regex "^\\s*function\\s*[^=]+\\s*=\\s*JJJ\\b" + :tests ("\tfunction y = test(asdf)" "function x = test()" "function [x, losses] = test(A, y, lambda, method, qtile)") + :not ("\tfunction testnot(asdf)" "function testnot()")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "matlab" + :regex "^\\s*classdef\\s*JJJ\\b\\s*" + :tests ("classdef test") + :not ("classdef testnot")) + + ;; nim + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "nim" + :regex "(const|let|var)\\s*JJJ\\*?\\s*(=|:)[^=:\\n]+" + :tests ("let test = 1234" "var test = 1234" "var test: Stat" "const test = 1234" "const test* = 1234") + :not ("if test == 1234:")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "nim" + :regex "(proc|func|macro|template)\\s*`?JJJ`?\\b\\*?\\s*\\\(" + :tests ("\tproc test(asdf)" "proc test()" "func test()" "macro test()" "template test()" "proc test*()") + :not ("\tproc testnot(asdf)" "proc testnot()")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "nim" + :regex "type\\s*JJJ\\b\\*?\\s*(\\{[^}]+\\})?\\s*=\\s*\\w+" + :tests ("type test = object" "type test {.pure.} = enum" "type test* = ref object") + :not ("type testnot = object")) + + ;; nix + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "nix" + :regex "\\b\\s*JJJ\\s*=[^=;]+" + :tests ("test = 1234;" "test = 123;" "test=123") + :not ("testNot = 1234;" "Nottest = 1234;" "AtestNot = 1234;")) + + ;; ruby + (:type "variable" :supports ("ag" "rg" "git-grep") :language "ruby" + :regex "^\\s*((\\w+[.])*\\w+,\\s*)*JJJ(,\\s*(\\w+[.])*\\w+)*\\s*=([^=>~]|$)" + :tests ("test = 1234" "self.foo, test, bar = args") + :not ("if test == 1234" "foo_test = 1234")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "ruby" + :regex "(^|[^\\w.])((private|public|protected)\\s+)?def\\s+(\\w+(::|[.]))*JJJ($|[^\\w|:])" + :tests ("def test(foo)" "def test()" "def test foo" "def test; end" + "def self.test()" "def MODULE::test()" "private def test") + :not ("def test_foo")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "ruby" + :regex "(^|\\W)define(_singleton|_instance)?_method(\\s|[(])\\s*:JJJ($|[^\\w|:])" + :tests ("define_method(:test, &body)" + "mod.define_instance_method(:test) { body }")) + + (:type "type" :supports ("ag" "rg" "git-grep") :language "ruby" + :regex "(^|[^\\w.])class\\s+(\\w*::)*JJJ($|[^\\w|:])" + :tests ("class test" "class Foo::test")) + + (:type "type" :supports ("ag" "rg" "git-grep") :language "ruby" + :regex "(^|[^\\w.])module\\s+(\\w*::)*JJJ($|[^\\w|:])" + :tests ("module test" "module Foo::test")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "ruby" + :regex "(^|\\W)alias(_method)?\\W+JJJ(\\W|$)" + :tests ("alias test some_method" + "alias_method :test, :some_method" + "alias_method 'test' 'some_method'" + "some_class.send(:alias_method, :test, :some_method)") + :not ("alias some_method test" + "alias_method :some_method, :test" + "alias test_foo test")) + + ;; Groovy + (:type "variable" :supports ("ag" "rg" "git-grep") :language "groovy" + :regex "^\\s*((\\w+[.])*\\w+,\\s*)*JJJ(,\\s*(\\w+[.])*\\w+)*\\s*=([^=>~]|$)" + :tests ("test = 1234" "self.foo, test, bar = args") + :not ("if test == 1234" "foo_test = 1234")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "groovy" + :regex "(^|[^\\w.])((private|public)\\s+)?def\\s+(\\w+(::|[.]))*JJJ($|[^\\w|:])" + :tests ("def test(foo)" "def test()" "def test foo" "def test; end" + "def self.test()" "def MODULE::test()" "private def test") + :not ("def test_foo")) + + (:type "type" :supports ("ag" "rg" "git-grep") :language "groovy" + :regex "(^|[^\\w.])class\\s+(\\w*::)*JJJ($|[^\\w|:])" + :tests ("class test" "class Foo::test")) + + ;; crystal + (:type "variable" :supports ("ag" "rg" "git-grep") :language "crystal" + :regex "^\\s*((\\w+[.])*\\w+,\\s*)*JJJ(,\\s*(\\w+[.])*\\w+)*\\s*=([^=>~]|$)" + :tests ("test = 1234" "self.foo, test, bar = args") + :not ("if test == 1234" "foo_test = 1234")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "crystal" + :regex "(^|[^\\w.])((private|public|protected)\\s+)?def\\s+(\\w+(::|[.]))*JJJ($|[^\\w|:])" + :tests ("def test(foo)" "def test()" "def test foo" "def test; end" + "def self.test()" "def MODULE::test()" "private def test") + :not ("def test_foo")) + + (:type "type" :supports ("ag" "rg" "git-grep") :language "crystal" + :regex "(^|[^\\w.])class\\s+(\\w*::)*JJJ($|[^\\w|:])" + :tests ("class test" "class Foo::test")) + + (:type "type" :supports ("ag" "rg" "git-grep") :language "crystal" + :regex "(^|[^\\w.])module\\s+(\\w*::)*JJJ($|[^\\w|:])" + :tests ("module test" "module Foo::test")) + + (:type "type" :supports ("ag" "rg" "git-grep") :language "crystal" + :regex "(^|[^\\w.])struct\\s+(\\w*::)*JJJ($|[^\\w|:])" + :tests ("struct test" "struct Foo::test")) + + (:type "type" :supports ("ag" "rg" "git-grep") :language "crystal" + :regex "(^|[^\\w.])alias\\s+(\\w*::)*JJJ($|[^\\w|:])" + :tests ("alias test" "alias Foo::test")) + + ;; scad + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "scad" + :regex "\\s*\\bJJJ\\s*=[^=\\n]+" :tests ("test = 1234") :not ("if test == 1234 {")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "scad" + :regex "function\\s*JJJ\\s*\\\(" + :tests ("function test()" "function test ()")) + + (:type "module" :supports ("ag" "grep" "rg" "git-grep") :language "scad" + :regex "module\\s*JJJ\\s*\\\(" + :tests ("module test()" "module test ()")) + + ;; scala + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "scala" + :regex "\\bval\\s*JJJ\\s*=[^=\\n]+" :tests ("val test = 1234") :not ("case test => 1234")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "scala" + :regex "\\bvar\\s*JJJ\\s*=[^=\\n]+" :tests ("var test = 1234") :not ("case test => 1234")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "scala" + :regex "\\btype\\s*JJJ\\s*=[^=\\n]+" :tests ("type test = 1234") :not ("case test => 1234")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "scala" + :regex "\\bdef\\s*JJJ\\s*\\\(" + :tests ("def test(asdf)" "def test()")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "scala" + :regex "class\\s*JJJ\\s*\\\(?" + :tests ("class test(object)")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "scala" + :regex "trait\\s*JJJ\\s*\\\(?" + :tests ("trait test(object)")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "scala" + :regex "object\\s*JJJ\\s*\\\(?" + :tests ("object test(object)")) + + ;; solidity + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "solidity" + :regex "function\\s*JJJ\\s*\\\(" + :tests ("function test() internal" "function test (uint x, address y)" "function test() external")) + + (:type "modifier" :supports ("ag" "grep" "rg" "git-grep") :language "solidity" + :regex "modifier\\s*JJJ\\s*\\\(" + :tests ("modifier test()" "modifier test ()")) + + (:type "event" :supports ("ag" "grep" "rg" "git-grep") :language "solidity" + :regex "event\\s*JJJ\\s*\\\(" + :tests ("event test();" "event test (uint indexed x)" "event test(uint x, address y)")) + + (:type "error" :supports ("ag" "grep" "rg" "git-grep") :language "solidity" + :regex "error\\s*JJJ\\s*\\\(" + :tests ("error test();" "error test (uint x)" "error test(uint x, address y)")) + + (:type "contract" :supports ("ag" "grep" "rg" "git-grep") :language "solidity" + :regex "contract\\s*JJJ\\s*(is|\\\{)" + :tests ("contract test{" "contract test {" "contract test is foo")) + + ;; R + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "r" + :regex "\\bJJJ\\s*=[^=><]" :tests ("test = 1234") :not ("if (test == 1234)")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "r" + :regex "\\bJJJ\\s*<-\\s*function\\b" + :tests ("test <- function" "test <- function(") + :not ("test <- functionX")) + + ;; perl + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "perl" + :regex "sub\\s*JJJ\\s*(\\{|\\()" + :tests ("sub test{" "sub test {" "sub test(" "sub test (")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "perl" + :regex "JJJ\\s*=\\s*" + :tests ("$test = 1234")) + + ;; Tcl + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "tcl" + :regex "proc\\s+JJJ\\s*\\{" + :tests ("proc test{" "proc test {")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "tcl" + :regex "set\\s+JJJ" + :tests ("set test 1234")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "tcl" + :regex "(variable|global)\\s+JJJ" + :tests ("variable test" "global test")) + + ;; shell + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "shell" + :regex "function\\s*JJJ\\s*" + :tests ("function test{" "function test {" "function test () {") + :not ("function nottest {")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "shell" + :regex "JJJ\\\(\\\)\\s*\\{" + :tests ("test() {") + :not ("testx() {")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "shell" + :regex "\\bJJJ\\s*=\\s*" + :tests ("test = 1234") :not ("blahtest = 1234")) + + ;; php + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "php" + :regex "function\\s*JJJ\\s*\\\(" + :tests ("function test()" "function test ()")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "php" + :regex "\\*\\s@method\\s+[^ \t]+\\s+JJJ\\(" + :tests ("/** @method string|false test($a)" " * @method bool test()")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "php" + :regex "(\\s|->|\\$|::)JJJ\\s*=\\s*" + :tests ("$test = 1234" "$foo->test = 1234")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "php" + :regex "\\*\\s@property(-read|-write)?\\s+([^ \t]+\\s+)&?\\$JJJ(\\s+|$)" + :tests ("/** @property string $test" "/** @property string $test description for $test property" " * @property-read bool|bool $test" " * @property-write \\ArrayObject $test")) + (:type "trait" :supports ("ag" "grep" "rg" "git-grep") :language "php" + :regex "trait\\s*JJJ\\s*\\\{" + :tests ("trait test{" "trait test {")) + + (:type "interface" :supports ("ag" "grep" "rg" "git-grep") :language "php" + :regex "interface\\s*JJJ\\s*\\\{" + :tests ("interface test{" "interface test {")) + + (:type "class" :supports ("ag" "grep" "rg" "git-grep") :language "php" + :regex "class\\s*JJJ\\s*(extends|implements|\\\{)" + :tests ("class test{" "class test {" "class test extends foo" "class test implements foo")) + + ;; dart + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "dart" + :regex "\\bJJJ\\s*\\([^()]*\\)\\s*[{]" + :tests ("test(foo) {" "test (foo){" "test(foo){")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "dart" + :regex "class\\s*JJJ\\s*[\\\(\\\{]" + :tests ("class test(object) {" "class test{")) + + ;; faust + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "faust" + :regex "\\bJJJ\(\\\(.+\\\)\)*\\s*=" + :tests ("test = osc + 0.5;" "test(freq) = osc(freq) + 0.5;")) + + ;; fennel + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "fennel" + :regex "\\((local|var)\\s+JJJ\\j" + :tests ("(local test (foo)" + "(var test (foo)")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "fennel" + :regex "\\(fn\\s+JJJ\\j" + :tests ("(fn test [foo]") + :not ("(fn test? [foo]")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "fennel" + :regex "\\(macro\\s+JJJ\\j" + :tests ("(macro test [foo]")) + + ;; fortran + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "fortran" + :regex "\\s*\\bJJJ\\s*=[^=\\n]+" + :tests ("test = 1234") + :not ("if (test == 1234)")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "fortran" + :regex "\\b(function|subroutine|FUNCTION|SUBROUTINE)\\s+JJJ\\b\\s*\\\(" + :tests ("function test (foo)" "integer function test(foo)" + "subroutine test (foo, bar)" "FUNCTION test (foo)" + "INTEGER FUNCTION test(foo)" "SUBROUTINE test (foo, bar)") + :not ("end function test" "end subroutine test" "END FUNCTION test" + "END SUBROUTINE test")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "fortran" + :regex "^\\s*(interface|INTERFACE)\\s+JJJ\\b" + :tests ("interface test" "INTERFACE test") + :not ("interface test2" "end interface test" "INTERFACE test2" + "END INTERFACE test")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "fortran" + :regex "^\\s*(module|MODULE)\\s+JJJ\\s*" + :tests ("module test" "MODULE test") + :not ("end module test" "END MODULE test")) + + ;; go + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "go" + :regex "\\s*\\bJJJ\\s*=[^=\\n]+" :tests ("test = 1234") :not ("if test == 1234 {")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "go" + :regex "\\s*\\bJJJ\\s*:=\\s*" :tests ("test := 1234")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "go" + :regex "func\\s+\\\([^\\\)]*\\\)\\s+JJJ\\s*\\\(" + :tests ("func (s *blah) test(filename string) string {")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "go" + :regex "func\\s+JJJ\\s*\\\(" + :tests ("func test(url string) (string, error)")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "go" + :regex "type\\s+JJJ\\s+struct\\s+\\\{" + :tests ("type test struct {")) + + ;; javascript extended + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "javascript" + :regex "(service|factory)\\\(['\"]JJJ['\"]" :tags ("angular") + :tests ("module.factory('test', [\"$rootScope\", function($rootScope) {")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "javascript" + :regex "\\bJJJ\\s*[=:]\\s*\\\([^\\\)]*\\\)\\s+=>" :tags ("es6") + :tests ("const test = (foo) => " "test: (foo) => {" " test: (foo) => {")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "javascript" + :regex "\\bJJJ\\s*\\([^()]*\\)\\s*[{]" :tags ("es6") + :tests ("test(foo) {" "test (foo){" "test(foo){") + :not ("test = blah.then(function(){")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "javascript" :tags ("es6") + :regex "class\\s*JJJ\\s*[\\\(\\\{]" + :tests ("class test(object) {" "class test{")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "javascript" :tags ("es6") + :regex "class\\s*JJJ\\s+extends" + :tests ("class test extends Component{")) + + ;; javascript + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "javascript" + :regex "\\s*\\bJJJ\\s*=[^=\\n]+" :tests ("test = 1234" "const test = props =>") :not ("if (test === 1234)")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "javascript" + :regex "\\bfunction\\b[^\\(]*\\\(\\s*[^\\)]*\\bJJJ\\b\\s*,?\\s*\\\)?" + :tests ("function (test)" "function (test, blah)" "function somefunc(test, blah) {" "function(blah, test)") + :not ("function (testLen)" "function (test1, blah)" "function somefunc(testFirst, blah) {" "function(blah, testLast)" + "function (Lentest)" "function (blahtest, blah)" "function somefunc(Firsttest, blah) {" "function(blah, Lasttest)")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "javascript" + :regex "function\\s*JJJ\\s*\\\(" + :tests ("function test()" "function test ()")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "javascript" + :regex "\\bJJJ\\s*:\\s*function\\s*\\\(" + :tests ("test: function()")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "javascript" + :regex "\\bJJJ\\s*=\\s*function\\s*\\\(" + :tests ("test = function()")) + + ;; hcl terraform + (:type "block" :supports ("ag" "grep" "rg" "git-grep") :language "hcl" + :regex "(variable|output|module)\\s*\"JJJ\"\\s*\\\{" + :tests ("variable \"test\" {" + "output \"test\" {" + "module \"test\" {")) + + (:type "block" :supports ("ag" "grep" "rg" "git-grep") :language "hcl" + :regex "(data|resource)\\s*\"\\w+\"\\s*\"JJJ\"\\s*\\\{" + :tests ("data \"openstack_images_image_v2\" \"test\" {" + "resource \"google_compute_instance\" \"test\" {")) + + ;; typescript + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "typescript" + :regex "(service|factory)\\\(['\"]JJJ['\"]" :tags ("angular") + :tests ("module.factory('test', [\"$rootScope\", function($rootScope) {")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "typescript" + :regex "\\bJJJ\\s*[=:]\\s*\\\([^\\\)]*\\\)\\s+=>" + :tests ("const test = (foo) => " "test: (foo) => {" " test: (foo) => {")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "typescript" + :regex "\\bJJJ\\s*\\([^()]*\\)\\s*[{]" + :tests ("test(foo) {" "test (foo){" "test(foo){") + :not ("test = blah.then(function(){")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "typescript" + :regex "class\\s*JJJ\\s*[\\\(\\\{]" + :tests ("class test{")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "typescript" + :regex "class\\s*JJJ\\s+extends" + :tests ("class test extends Component{")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "typescript" + :regex "function\\s*JJJ\\s*\\\(" + :tests ("function test()" "function test ()")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "typescript" + :regex "\\bJJJ\\s*:\\s*function\\s*\\\(" + :tests ("test: function()")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "typescript" + :regex "\\bJJJ\\s*=\\s*function\\s*\\\(" + :tests ("test = function()")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "typescript" + :regex "\\s*\\bJJJ\\s*=[^=\\n]+" :tests ("test = 1234" "const test = props =>") :not ("if (test === 1234)")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "typescript" + :regex "\\bfunction\\b[^\\(]*\\\(\\s*[^\\)]*\\bJJJ\\b\\s*,?\\s*\\\)?" + :tests ("function (test)" "function (test, blah)" "function somefunc(test, blah) {" "function(blah, test)") + :not ("function (testLen)" "function (test1, blah)" "function somefunc(testFirst, blah) {" "function(blah, testLast)" + "function (Lentest)" "function (blahtest, blah)" "function somefunc(Firsttest, blah) {" "function(blah, Lasttest)")) + + ;; julia + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "julia" + :regex "(@noinline|@inline)?\\s*function\\s*JJJ(\\{[^\\}]*\\})?\\(" + :tests ("function test()" "@inline function test()" + "function test{T}(h)")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "julia" + :regex "(@noinline|@inline)?JJJ(\\{[^\\}]*\\})?\\([^\\)]*\\)\s*=" + :tests ("test(a)=1" "test(a,b)=1*8" + "@noinline test()=1" "test{T}(x)=x")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "julia" + :regex "macro\\s*JJJ\\(" + :tests ("macro test(a)=1" " macro test(a,b)=1*8")) + + (:type "variable" :supports ("ag" "rg") :language "julia" + :regex "const\\s+JJJ\\b" + :tests ("const test = ")) + + (:type "type" :supports ("ag" "rg") :language "julia" + :regex "(mutable)?\\s*struct\\s*JJJ" + :tests ("struct test")) + + (:type "type" :supports ("ag" "rg") :language "julia" + :regex "(type|immutable|abstract)\\s*JJJ" + :tests ("type test" "immutable test" "abstract test <:Testable" )) + + ;; haskell + (:type "module" :supports ("ag") :language "haskell" + :regex "^module\\s+JJJ\\s+" + :tests ("module Test (exportA, exportB) where")) + + ; TODO Doesn't support any '=' in arguments. E.g. 'foo A{a = b,..} = bar'. + (:type "top level function" :supports ("ag") :language "haskell" + :regex "^\\bJJJ(?!(\\s+::))\\s+((.|\\s)*?)=\\s+" + :tests ("test n = n * 2" + "test X{..} (Y a b c) \n bcd \n =\n x * y" + "test ab cd e@Datatype {..} (Another thing, inTheRow) = \n undefined" + "test = runRealBasedMode @ext @ctx identity identity" + "test unwrap wrap nr@Naoeu {..} (Action action, specSpecs) = \n undefined") + :not ("nottest n = n * 2" + "let testnot x y = x * y" "test $ y z" "let test a o = mda" + "test :: Sometype -> AnotherType aoeu kek = undefined")) + + (:type "type-like" :supports ("ag") :language "haskell" + :regex "^\\s*((data(\\s+family)?)|(newtype)|(type(\\s+family)?))\\s+JJJ\\s+" + :tests ("newtype Test a = Something { b :: Kek }" + "data Test a b = Somecase a | Othercase b" + "type family Test (x :: *) (xs :: [*]) :: Nat where" + "data family Test " + "type Test = TestAlias") + :not ("newtype NotTest a = NotTest (Not a)" + "data TestNot b = Aoeu")) + + ; datatype contstuctor that doesn't match type definition. + (:type "(data)type constructor 1" :supports ("ag") :language "haskell" + :regex "(data|newtype)\\s{1,3}(?!JJJ\\s+)([^=]{1,40})=((\\s{0,3}JJJ\\s+)|([^=]{0,500}?((?\\s*)?JJJ\\s+" + :tests ( + "class (Constr1 m, Constr 2) => Test (Kek a) where" + "class Test (Veryovka a) where ") + :not ("class Test2 (Kek a) where" + "class MakeTest (AoeuTest x y z) where")) + + ;; ocaml + (:type "type" :supports ("ag" "rg") :language "ocaml" + :regex "^\\s*(and|type)\\s+.*\\bJJJ\\b" + :tests ("type test =" + "and test =" + "type 'a test =" + "type ('a, _, 'c) test")) + + (:type "variable" :supports ("ag" "rg") :language "ocaml" + :regex "let\\s+JJJ\\b" + :tests ("let test =" + "let test x y =")) + + (:type "variable" :supports ("ag" "rg") :language "ocaml" + :regex "let\\s+rec\\s+JJJ\\b" + :tests ("let rec test =" + "let rec test x y =")) + + (:type "variable" :supports ("ag" "rg") :language "ocaml" + :regex "\\s*val\\s*\\bJJJ\\b\\s*" + :tests ("val test")) + + (:type "module" :supports ("ag" "rg") :language "ocaml" + :regex "^\\s*module\\s*\\bJJJ\\b" + :tests ("module test =")) + + (:type "module" :supports ("ag" "rg") :language "ocaml" + :regex "^\\s*module\\s*type\\s*\\bJJJ\\b" + :tests ("module type test =")) + + ;; lua + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "lua" + :regex "\\s*\\bJJJ\\s*=[^=\\n]+" :tests ("test = 1234") :not ("if test === 1234")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "lua" + :regex "\\bfunction\\b[^\\(]*\\\(\\s*[^\\)]*\\bJJJ\\b\\s*,?\\s*\\\)?" + :tests ("function (test)" "function (test, blah)" "function somefunc(test, blah)" "function(blah, test)") + :not ("function (testLen)" "function (test1, blah)" "function somefunc(testFirst, blah)" "function(blah, testLast)" + "function (Lentest)" "function (blahtest, blah)" "function somefunc(Firsttest, blah)" "function(blah, Lasttest)")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "lua" + :regex "function\\s*JJJ\\s*\\\(" + :tests ("function test()" "function test ()")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "lua" + :regex "function\\s*.+[.:]JJJ\\s*\\\(" + :tests ("function MyClass.test()" "function MyClass.test ()" + "function MyClass:test()" "function MyClass:test ()")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "lua" + :regex "\\bJJJ\\s*=\\s*function\\s*\\\(" + :tests ("test = function()")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "lua" + :regex "\\b.+\\.JJJ\\s*=\\s*function\\s*\\\(" + :tests ("MyClass.test = function()")) + + ;; rust + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "\\blet\\s+(\\\([^=\\n]*)?(mut\s+)?JJJ([^=\\n]*\\\))?(:\\s*[^=\\n]+)?\\s*=\\s*[^=\\n]+" + :tests ("let test = 1234;" + "let test: u32 = 1234;" + "let test: Vec = Vec::new();" + "let mut test = 1234;" + "let mut test: Vec = Vec::new();" + "let (a, test, b) = (1, 2, 3);" + "let (a, mut test, mut b) = (1, 2, 3);" + "let (mut a, mut test): (u32, usize) = (1, 2);")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "\\bconst\\s+JJJ:\\s*[^=\\n]+\\s*=[^=\\n]+" + :tests ("const test: u32 = 1234;")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "\\bstatic\\s+(mut\\s+)?JJJ:\\s*[^=\\n]+\\s*=[^=\\n]+" + :tests ("static test: u32 = 1234;" + "static mut test: u32 = 1234;")) + + ;; variable in method signature + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "\\bfn\\s+.+\\s*\\\((.+,\\s+)?JJJ:\\s*[^=\\n]+\\s*(,\\s*.+)*\\\)" + :tests ("fn abc(test: u32) -> u32 {" + "fn abc(x: u32, y: u32, test: Vec, z: Vec)" + "fn abc(x: u32, y: u32, test: &mut Vec, z: Vec)")) + + ;; "if let" and "while let" desugaring + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "(if|while)\\s+let\\s+([^=\\n]+)?(mut\\s+)?JJJ([^=\\n\\\(]+)?\\s*=\\s*[^=\\n]+" + :tests ("if let Some(test) = abc() {" + "if let Some(mut test) = abc() {" + "if let Ok(test) = abc() {" + "if let Ok(mut test) = abc() {" + "if let Foo(mut test) = foo {" + "if let test = abc() {" + "if let Some(test) = abc()" + "if let Some((a, test, b)) = abc()" + "while let Some(test) = abc() {" + "while let Some(mut test) = abc() {" + "while let Ok(test) = abc() {" + "while let Ok(mut test) = abc() {") + :not ("while let test(foo) = abc() {")) + + ;; structure fields + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "struct\\s+[^\\n{]+[{][^}]*(\\s*JJJ\\s*:\\s*[^\\n},]+)[^}]*}" + :tests ("struct Foo { abc: u32, test: Vec, b: PathBuf }" + "struct Foo{test:Vec}" + "struct FooBar<'a> { test: Vec }") + :not ("struct Foo { abc: u32, b: Vec }" + "/// ... construct the equivalent ...\nfn abc() {\n")) + + ;; enum variants + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "enum\\s+[^\\n{]+\\s*[{][^}]*\\bJJJ\\b[^}]*}" + :tests ("enum Foo { VariantA, test, VariantB(u32) }" + "enum Foo { test(T) }" + "enum BadStyle{test}" + "enum Foo32 { Bar, testing, test(u8) }") + :not ("enum Foo { testing }")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "\\bfn\\s+JJJ\\s*\\\(" + :tests ("fn test(asdf: u32)" "fn test()" "pub fn test()")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "\\bmacro_rules!\\s+JJJ" + :tests ("macro_rules! test")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "struct\\s+JJJ\\s*[{\\\(]?" + :tests ("struct test(u32, u32)" + "struct test;" + "struct test { abc: u32, def: Vec }")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "trait\\s+JJJ\\s*[{]?" + :tests ("trait test;" "trait test { fn abc() -> u32; }")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "\\btype\\s+JJJ([^=\\n]+)?\\s*=[^=\\n]+;" + :tests ("type test = Rc>;" + "type test = Arc>>;")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "impl\\s+((\\w+::)*\\w+\\s+for\\s+)?(\\w+::)*JJJ\\s+[{]?" + :tests ("impl test {" + "impl abc::test {" + "impl std::io::Read for test {" + "impl std::io::Read for abc::test {")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "rust" + :regex "mod\\s+JJJ\\s*[{]?" + :tests ("mod test;" "pub mod test {")) + + ;; elixir + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "elixir" + :regex "\\bdef(p)?\\s+JJJ\\s*[ ,\\\(]" + :tests ("def test do" + "def test, do:" + "def test() do" + "def test(), do:" + "def test(foo, bar) do" + "def test(foo, bar), do:" + "defp test do" + "defp test(), do:")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "elixir" + :regex "\\s*JJJ\\s*=[^=\\n]+" + :tests ("test = 1234") + :not ("if test == 1234")) + + (:type "module" :supports ("ag" "grep" "rg" "git-grep") :language "elixir" + :regex "defmodule\\s+(\\w+\\.)*JJJ\\s+" + :tests ("defmodule test do" + "defmodule Foo.Bar.test do")) + + (:type "module" :supports ("ag" "grep" "rg" "git-grep") :language "elixir" + :regex "defprotocol\\s+(\\w+\\.)*JJJ\\s+" + :tests ("defprotocol test do" + "defprotocol Foo.Bar.test do")) + + ;; erlang + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "erlang" + :regex "^JJJ\\b\\s*\\\(" + :tests ("test() ->" + "test()->" + "test(Foo) ->" + "test (Foo,Bar) ->" + "test(Foo, Bar)->")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "erlang" + :regex "\\s*JJJ\\s*=[^:=\\n]+" + :tests ("test = 1234") + :not ("if test =:= 1234" + "if test == 1234")) + + (:type "module" :supports ("ag" "grep" "rg" "git-grep") :language "erlang" + :regex "^-module\\\(JJJ\\\)" + :tests ("-module(test).")) + + ;; scss + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "scss" + :regex "@mixin\\sJJJ\\b\\s*\\\(" + :tests ("@mixin test()")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "scss" + :regex "@function\\sJJJ\\b\\s*\\\(" + :tests ("@function test()")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "scss" + :regex "JJJ\\s*:\\s*" + :tests ("test :")) + + ;; sml + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "sml" + :regex "\\s*(data)?type\\s+.*\\bJJJ\\b" + :tests ("datatype test =" + "datatype test=" + "datatype 'a test =" + "type test =" + "type 'a test =" + "type 'a test" + "type test") + :not ("datatypetest =")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "sml" + :regex "\\s*val\\s+\\bJJJ\\b" + :tests ("val test =" + "val test=" + "val test : bool")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "sml" + :regex "\\s*fun\\s+\\bJJJ\\b.*\\s*=" + :tests ("fun test list =" + "fun test (STRING_NIL, a) =" + "fun test ((s1,s2): 'a queue) : 'a * 'a queue =" + "fun test (var : q) : int =" + "fun test f e xs =")) + + (:type "module" :supports ("ag" "grep" "rg" "git-grep") :language "sml" + :regex "\\s*(structure|signature|functor)\\s+\\bJJJ\\b" + :tests ("structure test =" + "structure test : MYTEST =" + "signature test =" + "functor test (T:TEST) =" + "functor test(T:TEST) =")) + + ;; sql + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "sql" + :regex "(CREATE|create)\\s+(.+?\\s+)?(FUNCTION|function|PROCEDURE|procedure)\\s+JJJ\\s*\\\(" + :tests ("CREATE FUNCTION test(i INT) RETURNS INT" + "create or replace function test (int)" + "CREATE PROCEDURE test (OUT p INT)" + "create definer = 'test'@'localhost' procedure test()")) + + (:type "table" :supports ("ag" "grep" "rg" "git-grep") :language "sql" + :regex "(CREATE|create)\\s+(.+?\\s+)?(TABLE|table)(\\s+(IF NOT EXISTS|if not exists))?\\s+JJJ\\b" + :tests ("CREATE TABLE test (" + "create temporary table if not exists test" + "CREATE TABLE IF NOT EXISTS test (" + "create global temporary table test")) + + (:type "view" :supports ("ag" "grep" "rg" "git-grep") :language "sql" + :regex "(CREATE|create)\\s+(.+?\\s+)?(VIEW|view)\\s+JJJ\\b" + :tests ("CREATE VIEW test (" + "create sql security definer view test" + "CREATE OR REPLACE VIEW test AS foo")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "sql" + :regex "(CREATE|create)\\s+(.+?\\s+)?(TYPE|type)\\s+JJJ\\b" + :tests ("CREATE TYPE test" + "CREATE OR REPLACE TYPE test AS foo (" + "create type test as (")) + + ;; systemverilog + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "systemverilog" + :regex "\\s*class\\s+\\bJJJ\\b" + :tests ("virtual class test;" "class test;" "class test extends some_class") + :not ("virtual class testing;" "class test2;" "class some_test" "class some_class extends test")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "systemverilog" + :regex "\\s*task\\s+\\bJJJ\\b" + :tests ("task test (" "task test(") + :not ("task testing (" "task test2(")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "systemverilog" + :regex "\\s*\\bJJJ\\b\\s*=" + :tests ("assign test =" "assign test=" "int test =" "int test=") + :not ("assign testing =" "assign test2=")) + + (:type "function" :supports ("ag" "rg" "git-grep") :language "systemverilog" + :regex "function\\s[^\\s]+\\s*\\bJJJ\\b" + :tests ("function Matrix test ;" "function Matrix test;") + :not ("function test blah")) + + ;; matches SV class handle declarations + (:type "function" :supports ("ag" "rg" "git-grep") :language "systemverilog" + :regex "^\\s*[^\\s]*\\s*[^\\s]+\\s+\\bJJJ\\b" + :tests ("some_class_name test" " another_class_name test ;" "some_class test[];" "some_class #(1) test") + :not ("test some_class_name" "class some_class extends test")) + + ;; vhdl + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "vhdl" + :regex "\\s*type\\s+\\bJJJ\\b" + :tests ("type test is" "type test is") + :not ("type testing is" "type test2 is")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "vhdl" + :regex "\\s*constant\\s+\\bJJJ\\b" + :tests ("constant test :" "constant test:") + :not ("constant testing " "constant test2:")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "vhdl" + :regex "function\\s*\"?JJJ\"?\\s*\\\(" + :tests ("function test(signal)" "function test (signal)" "function \"test\" (signal)") + :not ("function testing(signal")) + + ;; latex + (:type "command" :supports ("ag" "grep" "rg" "git-grep") :language "tex" + :regex "\\\\.*newcommand\\\*?\\s*\\\{\\s*(\\\\)JJJ\\s*}" + :tests ("\\newcommand{\\test}" "\\renewcommand{\\test}" "\\renewcommand*{\\test}" "\\newcommand*{\\test}" "\\renewcommand{ \\test }") + :not("\\test" "test")) + + (:type "command" :supports ("ag" "grep" "rg" "git-grep") :language "tex" + :regex "\\\\.*newcommand\\\*?\\s*(\\\\)JJJ\\j" + :tests ("\\newcommand\\test {}" "\\renewcommand\\test{}" "\\newcommand \\test") + :not("\\test" "test")) + + (:type "length" :supports ("ag" "grep" "rg" "git-grep") :language "tex" + :regex "\\\\(s)etlength\\s*\\\{\\s*(\\\\)JJJ\\s*}" + :tests ("\\setlength { \\test}" "\\setlength{\\test}" "\\setlength{\\test}{morecommands}" ) + :not("\\test" "test")) + + (:type "counter" :supports ("ag" "grep" "rg" "git-grep") :language "tex" + :regex "\\\\newcounter\\\{\\s*JJJ\\s*}" + :tests ("\\newcounter{test}" ) + :not("\\test" "test")) + + (:type "environment" :supports ("ag" "grep" "rg" "git-grep") :language "tex" + :regex "\\\\.*newenvironment\\s*\\\{\\s*JJJ\\s*}" + :tests ("\\newenvironment{test}" "\\newenvironment {test}{morecommands}" "\\lstnewenvironment{test}" "\\newenvironment {test}" ) + :not("\\test" "test" )) + + ;; pascal (todo: var, type, const) + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "pascal" + :regex "\\bfunction\\s+JJJ\\b" + :tests (" function test : ")) + + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "pascal" + :regex "\\bprocedure\\s+JJJ\\b" + :tests (" procedure test ; ")) + + ;; f# + (:type "variable" :supports ("ag" "grep" "git-grep") :language "fsharp" + :regex "let\\s+JJJ\\b.*\\\=" + :tests ("let test = 1234" "let test() = 1234" "let test abc def = 1234") + :not ("let testnot = 1234" "let testnot() = 1234" "let testnot abc def = 1234")) + + (:type "interface" :supports ("ag" "grep" "git-grep") :language "fsharp" + :regex "member(\\b.+\\.|\\s+)JJJ\\b.*\\\=" + :tests ("member test = 1234" "member this.test = 1234") + :not ("member testnot = 1234" "member this.testnot = 1234")) + + (:type "type" :supports ("ag" "grep" "git-grep") :language "fsharp" + :regex "type\\s+JJJ\\b.*\\\=" + :tests ("type test = 1234") + :not ("type testnot = 1234")) + + ;; kotlin + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "kotlin" + :regex "fun\\s*(<[^>]*>)?\\s*JJJ\\s*\\(" + :tests ("fun test()" "fun test()")) + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "kotlin" + :regex "(val|var)\\s*JJJ\\b" + :not ("val testval" "var testvar") + :tests ("val test " "var test")) + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "kotlin" + :regex "(class|interface)\\s*JJJ\\b" + :tests ("class test" "class test : SomeInterface" "interface test")) + + ;; zig + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "zig" + :regex "fn\\s+JJJ\\b" + :tests ("fn test() void {" + "fn test(a: i32) i32 {" + "pub fn test(a: i32) i32 {" + "export fn test(a: i32) i32 {" + "extern \"c\" fn test(a: i32) i32 {" + "inline fn test(a: i32) i32 {")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "zig" + :regex "(var|const)\\s+JJJ\\b" + :tests ("const test: i32 = 3;" + "var test: i32 = 3;" + "pub const test: i32 = 3;")) + + ;; protobuf + (:type "message" :supports ("ag" "grep" "rg" "git-grep") :language "protobuf" + :regex "message\\s+JJJ\\s*\\\{" + :tests ("message test{" "message test {")) + + (:type "enum" :supports ("ag" "grep" "rg" "git-grep") :language "protobuf" + :regex "enum\\s+JJJ\\s*\\\{" + :tests ("enum test{" "enum test {")) + + ;; apex (literally the same regexes as java) + (:type "function" :supports ("ag" "rg") :language "apex" + :regex "^\\s*(?:[\\w\\[\\]]+\\s+){1,3}JJJ\\s*\\\(" + :tests ("int test()" "int test(param)" "static int test()" "static int test(param)" + "public static MyType test()" "private virtual SomeType test(param)" "static int test()" + "private foo[] test()") + :not ("test()" "testnot()" "blah = new test()" "foo bar = test()")) + + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "apex" + :regex "\\s*\\bJJJ\\s*=[^=\\n)]+" :tests ("int test = 1234") :not ("if test == 1234:" "int nottest = 44")) + + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "apex" + :regex "(class|interface)\\s*JJJ\\b" + :tests ("class test:" "public class test implements Something") + :not ("class testnot:" "public class testnot implements Something")) + + ;; jai + (:type "function" :supports ("ag" "grep" "rg" "git-grep") :language "jai" + :regex "\\bJJJ\\s*::" + :tests ("test ::")) + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "jai" + :regex "\\bJJJ\\s*(:|:\\s*=|::)" + :tests ("test: Type" "test : Type = Val" "test :: Val")) + (:type "type" :supports ("ag" "grep" "rg" "git-grep") :language "jai" + :regex "\\bJJJ\\s*::" + :tests ("test ::")) + + ;; odin + (:type "variable" :supports ("ag" "grep" "rg" "git-grep") :language "odin" + :regex "\\s*\\bJJJ\\s*:\\s*([^=\\n]+\\s*:|:|[^=\\n]+\\s*=|=)" + :tests ("test :: struct" + "test ::enum" + "test:: union" + "test: : custom_type" + "test :: [2]f32" + "test : f32 : 20" + "test: i32 : 10" + "test := 20" + "test : f32 = 20" + "test: i32 = 10" + "test: i32= 10" + "test :i32= 10" + "test :: proc()" + "test ::proc() {" + "test:: proc(a: i32) -> i32 {" + "test::proc{}" + "test: :proc \"contextless\" {}"))) + + + "List of regex patttern templates organized by language and type to use for generating the grep command." + :group 'dumb-jump + :type + '(repeat + (plist + :options ((:type string) + (:supports string) + (:language string) + (:regex string) + (:tests (repeat string)) + (:not (repeat string)))))) + + ; https://github.com/ggreer/the_silver_searcher/blob/master/tests/list_file_types.t + ; https://github.com/BurntSushi/ripgrep/blob/master/ignore/src/types.rs#L99 +(defcustom dumb-jump-language-file-exts + '((:language "elisp" :ext "el" :agtype "elisp" :rgtype "elisp") + (:language "elisp" :ext "el.gz" :agtype "elisp" :rgtype "elisp") + (:language "commonlisp" :ext "lisp" :agtype "lisp" :rgtype "lisp") + (:language "commonlisp" :ext "lsp" :agtype "lisp" :rgtype "lisp") + (:language "c++" :ext "c" :agtype "cc" :rgtype "c") + (:language "c++" :ext "h" :agtype "cc" :rgtype "c") + (:language "c++" :ext "C" :agtype "cpp" :rgtype "cpp") + (:language "c++" :ext "H" :agtype "cpp" :rgtype "cpp") + (:language "c++" :ext "tpp" :agtype "cpp" :rgtype nil) + (:language "c++" :ext "cpp" :agtype "cpp" :rgtype "cpp") + (:language "c++" :ext "hpp" :agtype "cpp" :rgtype "cpp") + (:language "c++" :ext "cxx" :agtype "cpp" :rgtype "cpp") + (:language "c++" :ext "hxx" :agtype "cpp" :rgtype nil) + (:language "c++" :ext "cc" :agtype "cpp" :rgtype "cpp") + (:language "c++" :ext "hh" :agtype "cpp" :rgtype "cpp") + (:language "c++" :ext "c++" :agtype nil :rgtype nil) + (:language "c++" :ext "h++" :agtype nil :rgtype nil) + (:language "coq" :ext "v" :agtype nil :rgtype nil) + (:language "ocaml" :ext "ml" :agtype "ocaml" :rgtype "ocaml") + (:language "ocaml" :ext "mli" :agtype "ocaml" :rgtype "ocaml") + (:language "ocaml" :ext "mll" :agtype "ocaml" :rgtype "ocaml") + (:language "ocaml" :ext "mly" :agtype "ocaml" :rgtype "ocaml") + ;; groovy is nil type because jenkinsfile is not in searcher type lists + (:language "groovy" :ext "gradle" :agtype nil :rgtype nil) + (:language "groovy" :ext "groovy" :agtype nil :rgtype nil) + (:language "groovy" :ext "jenkinsfile" :agtype nil :rgtype nil) + (:language "haskell" :ext "hs" :agtype "haskell" :rgtype "haskell") + (:language "haskell" :ext "lhs" :agtype "haskell" :rgtype "haskell") + (:language "objc" :ext "m" :agtype "objc" :rgtype "objc") + (:language "csharp" :ext "cs" :agtype "csharp" :rgtype "csharp") + (:language "java" :ext "java" :agtype "java" :rgtype "java") + (:language "vala" :ext "vala" :agtype "vala" :rgtype "vala") + (:language "vala" :ext "vapi" :agtype "vala" :rgtype "vala") + (:language "julia" :ext "jl" :agtype "julia" :rgtype "julia") + (:language "clojure" :ext "clj" :agtype "clojure" :rgtype "clojure") + (:language "clojure" :ext "cljc" :agtype "clojure" :rgtype "clojure") + (:language "clojure" :ext "cljs" :agtype "clojure" :rgtype "clojure") + (:language "clojure" :ext "cljx" :agtype "clojure" :rgtype "clojure") + (:language "coffeescript" :ext "coffee" :agtype "coffee" :rgtype "coffeescript") + (:language "faust" :ext "dsp" :agtype nil :rgtype nil) + (:language "faust" :ext "lib" :agtype nil :rgtype nil) + (:language "fennel" :ext "fnl" :agtype nil :rgtype nil) + (:language "fortran" :ext "F" :agtype "fortran" :rgtype "fortran") + (:language "fortran" :ext "f" :agtype "fortran" :rgtype "fortran") + (:language "fortran" :ext "f77" :agtype "fortran" :rgtype "fortran") + (:language "fortran" :ext "f90" :agtype "fortran" :rgtype "fortran") + (:language "fortran" :ext "f95" :agtype "fortran" :rgtype "fortran") + (:language "fortran" :ext "F77" :agtype "fortran" :rgtype "fortran") + (:language "fortran" :ext "F90" :agtype "fortran" :rgtype "fortran") + (:language "fortran" :ext "F95" :agtype "fortran" :rgtype "fortran") + (:language "fortran" :ext "f03" :agtype "fortran" :rgtype "fortran") + (:language "fortran" :ext "for" :agtype "fortran" :rgtype "fortran") + (:language "fortran" :ext "ftn" :agtype "fortran" :rgtype "fortran") + (:language "fortran" :ext "fpp" :agtype "fortran" :rgtype "fortran") + (:language "go" :ext "go" :agtype "go" :rgtype "go") + (:language "javascript" :ext "js" :agtype "js" :rgtype "js") + (:language "javascript" :ext "jsx" :agtype "js" :rgtype "js") + (:language "javascript" :ext "vue" :agtype "js" :rgtype "js") + (:language "javascript" :ext "html" :agtype "html" :rgtype "html") + (:language "javascript" :ext "css" :agtype "css" :rgtype "css") + (:language "typescript" :ext "ts" :agtype "ts" :rgtype "ts") + (:language "typescript" :ext "tsx" :agtype "ts" :rgtype "ts") + (:language "typescript" :ext "vue" :agtype "ts" :rgtype "ts") + (:language "dart" :ext "dart" :agtype nil :rgtype "dart") + (:language "lua" :ext "lua" :agtype "lua" :rgtype "lua") + ;; the extension "m" is also used by obj-c so must use matlab-mode + ;; since obj-c will win by file extension, but here for searcher types + (:language "matlab" :ext "m" :agtype "matlab" :rgtype "matlab") + (:language "nim" :ext "nim" :agtype "nim" :rgtype "nim") + (:language "nix" :ext "nix" :agtype "nix" :rgtype "nix") + (:language "org" :ext "org" :agtype nil :rgtype "org") + (:language "perl" :ext "pl" :agtype "perl" :rgtype "perl") + (:language "perl" :ext "pm" :agtype "perl" :rgtype "perl") + (:language "perl" :ext "pm6" :agtype "perl" :rgtype nil) + (:language "perl" :ext "perl" :agtype nil :rgtype "perl") + (:language "perl" :ext "plh" :agtype nil :rgtype "perl") + (:language "perl" :ext "plx" :agtype nil :rgtype "perl") + (:language "perl" :ext "pod" :agtype "perl" :rgtype "pod") + (:language "perl" :ext "t" :agtype "perl" :rgtype nil) + (:language "php" :ext "php" :agtype "php" :rgtype "php") + (:language "php" :ext "php3" :agtype "php" :rgtype "php") + (:language "php" :ext "php4" :agtype "php" :rgtype "php") + (:language "php" :ext "php5" :agtype "php" :rgtype "php") + (:language "php" :ext "phtml" :agtype "php" :rgtype "php") + (:language "php" :ext "inc" :agtype "php" :rgtype nil) + (:language "python" :ext "py" :agtype "python" :rgtype "py") + (:language "r" :ext "R" :agtype "r" :rgtype "r") + (:language "r" :ext "r" :agtype "r" :rgtype "r") + (:language "r" :ext "Rmd" :agtype "r" :rgtype "r") + (:language "r" :ext "Rnw" :agtype "r" :rgtype "r") + (:language "r" :ext "Rtex" :agtype "r" :rgtype nil) + (:language "r" :ext "Rrst" :agtype "r" :rgtype nil) + (:language "racket" :ext "rkt" :agtype "racket" :rgtype "lisp") + (:language "crystal" :ext "cr" :agtype "crystal" :rgtype "crystal") + (:language "crystal" :ext "ecr" :agtype "crystal" :rgtype nil) + (:language "ruby" :ext "rb" :agtype "ruby" :rgtype "ruby") + (:language "ruby" :ext "erb" :agtype "ruby" :rgtype nil) + (:language "ruby" :ext "haml" :agtype "ruby" :rgtype nil) + (:language "ruby" :ext "rake" :agtype "ruby" :rgtype nil) + (:language "ruby" :ext "slim" :agtype "ruby" :rgtype nil) + (:language "rust" :ext "rs" :agtype "rust" :rgtype "rust") + (:language "zig" :ext "zig" :agtype nil :rgtype "zig") + (:language "scad" :ext "scad" :agtype nil :rgtype nil) + (:language "scala" :ext "scala" :agtype "scala" :rgtype "scala") + (:language "scheme" :ext "scm" :agtype "scheme" :rgtype "lisp") + (:language "scheme" :ext "ss" :agtype "scheme" :rgtype "lisp") + (:language "scheme" :ext "sld" :agtype "scheme" :rgtype "lisp") + (:language "janet" :ext "janet" :agtype "janet" :rgtype "lisp") + (:language "shell" :ext "sh" :agtype nil :rgtype nil) + (:language "shell" :ext "bash" :agtype nil :rgtype nil) + (:language "shell" :ext "csh" :agtype nil :rgtype nil) + (:language "shell" :ext "ksh" :agtype nil :rgtype nil) + (:language "shell" :ext "tcsh" :agtype nil :rgtype nil) + (:language "sml" :ext "sml" :agtype "sml" :rgtype "sml") + (:language "solidity" :ext "sol" :agtype nil :rgtype nil) + (:language "sql" :ext "sql" :agtype "sql" :rgtype "sql") + (:language "swift" :ext "swift" :agtype nil :rgtype "swift") + (:language "tex" :ext "tex" :agtype "tex" :rgtype "tex") + (:language "elixir" :ext "ex" :agtype "elixir" :rgtype "elixir") + (:language "elixir" :ext "exs" :agtype "elixir" :rgtype "elixir") + (:language "elixir" :ext "eex" :agtype "elixir" :rgtype "elixir") + (:language "erlang" :ext "erl" :agtype "erlang" :rgtype "erlang") + (:language "systemverilog" :ext "sv" :agtype "verilog" :rgtype "verilog") + (:language "systemverilog" :ext "svh" :agtype "verilog" :rgtype "verilog") + (:language "vhdl" :ext "vhd" :agtype "vhdl" :rgtype "vhdl") + (:language "vhdl" :ext "vhdl" :agtype "vhdl" :rgtype "vhdl") + (:language "scss" :ext "scss" :agtype "css" :rgtype "css") + (:language "pascal" :ext "pas" :agtype "delphi" :rgtype nil) + (:language "pascal" :ext "dpr" :agtype "delphi" :rgtype nil) + (:language "pascal" :ext "int" :agtype "delphi" :rgtype nil) + (:language "pascal" :ext "dfm" :agtype "delphi" :rgtype nil) + (:language "fsharp" :ext "fs" :agtype "fsharp" :rgtype nil) + (:language "fsharp" :ext "fsi" :agtype "fsharp" :rgtype nil) + (:language "fsharp" :ext "fsx" :agtype "fsharp" :rgtype nil) + (:language "kotlin" :ext "kt" :agtype "kotlin" :rgtype "kotlin") + (:language "kotlin" :ext "kts" :agtype "kotlin" :rgtype "kotlin") + (:language "protobuf" :ext "proto" :agtype "proto" :rgtype "protobuf") + (:language "hcl" :ext "tf" :agtype "terraform" :rgtype "tf") + (:language "hcl" :ext "tfvars" :agtype "terraform" :rgtype nil) + (:language "apex" :ext "cls" :agtype nil :rgtype nil) + (:language "apex" :ext "trigger" :agtype nil :rgtype nil) + (:language "jai" :ext "jai" :agtype nil :rgtype nil) + (:language "odin" :ext "odin" :agtype nil :rgtype nil)) + + "Mapping of programming language(s) to file extensions." + :group 'dumb-jump + :type + '(repeat + (plist + :options ((:language (string :tag "Language")) + (:ext (string :tag "Extension")) + (:agtype (string :tag "Ag type")) + (:rgtype (string :tag "Ripgrep type")))))) + +(defcustom dumb-jump-language-contexts + '((:language "javascript" :type "function" :right "^(" :left nil) + (:language "javascript" :type "variable" :right nil :left "($") + (:language "javascript" :type "variable" :right "^)" :left "($") + (:language "javascript" :type "variable" :right "^\\." :left nil) + (:language "javascript" :type "variable" :right "^;" :left nil) + (:language "typescript" :type "function" :right "^(" :left nil) + (:language "perl" :type "function" :right "^(" :left nil) + (:language "tcl" :type "function" :left "\\[$" :right nil) + (:language "tcl" :type "function" :left "^\s*$" :right nil) + (:language "tcl" :type "variable" :left "\\$$" :right nil) + (:language "php" :type "function" :right "^(" :left nil) + (:language "php" :type "class" :right nil :left "new\s+") + (:language "elisp" :type "function" :right nil :left "($") + (:language "elisp" :type "variable" :right "^)" :left nil) + (:language "scheme" :type "function" :right nil :left "($") + (:language "scheme" :type "variable" :right "^)" :left nil) + (:language "jai" :type "function" :right "\\s*(" :left nil) + (:language "jai" :type "type" :left "\\s*:\\s*" :right nil)) + + "List of under points contexts for each language. +This helps limit the number of regular expressions we use +if we know that if there's a '(' immediately to the right of +a symbol then it's probably a function call" + :group 'dumb-jump + :type + '(repeat + (plist + :options ((:language (string :tag "Language")) + (:type (choice (const "function") + (const "variable"))) + (:left (choice (const :tag "Anything" nil) + (string :tag "Regular expression"))) + (:right (choice (const :tag "Anything" nil) + (string :tag "Regular expression"))))))) + +(defcustom dumb-jump-project-denoters + '(".dumbjump" ".projectile" ".git" ".hg" ".fslckout" ".bzr" "_darcs" ".svn" "Makefile" "PkgInfo" "-pkg.el" "_FOSSIL_") + "Files and directories that signify a directory is a project root." + :group 'dumb-jump + :type '(repeat (string :tag "Name"))) + +(defcustom dumb-jump-default-project "~" + "The default project to search within if a project root is not found." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-project nil + "The project to search within if normal denoters will not work. This should only be needed in the rarest of cases." + :group 'dumb-jump + :type 'string) + +(defcustom dumb-jump-before-jump-hook nil + "Hooks called before jumping." + :type 'hook + :group 'dumb-jump + :type 'hook) + +(defcustom dumb-jump-after-jump-hook nil + "Hooks called after jumping." + :type 'hook + :group 'dumb-jump + :type 'hook) + +(defcustom dumb-jump-aggressive + nil + "If `t` jump aggressively with the possibility of a false positive. +If `nil` always show list of more than 1 match." + :group 'dumb-jump + :type 'boolean) + +(defcustom dumb-jump-debug + nil + "If `t` will print helpful debug information." + :group 'dumb-jump + :type 'boolean) + +(defcustom dumb-jump-confirm-jump-to-modified-file + t + "If t, confirm before jumping to a modified file (which may lead to an +inaccurate jump). If nil, jump without confirmation but print a warning." + :group 'dumb-jump + :type 'boolean) + +(defcustom dumb-jump-disable-obsolete-warnings nil + "If non-nil, don't warn about using the legacy interface." + :group 'dumb-jump + :type 'boolean) + +(defun dumb-jump-message-prin1 (str &rest args) + "Helper function when debugging apply STR 'prin1-to-string' to all ARGS." + (apply 'message str (-map 'prin1-to-string args))) + +(defvar dumb-jump--ag-installed? 'unset) +(defun dumb-jump-ag-installed? () + "Return t if ag is installed." + (if (eq dumb-jump--ag-installed? 'unset) + (setq dumb-jump--ag-installed? + (s-contains? "ag version" (shell-command-to-string (concat dumb-jump-ag-cmd " --version")))) + dumb-jump--ag-installed?)) + +(defvar dumb-jump--git-grep-plus-ag-installed? 'unset) +(defun dumb-jump-git-grep-plus-ag-installed? () + "Return t if git grep and ag is installed." + (if (eq dumb-jump--git-grep-plus-ag-installed? 'unset) + (setq dumb-jump--git-grep-plus-ag-installed? + (and (dumb-jump-git-grep-installed?) (dumb-jump-ag-installed?))) + dumb-jump--git-grep-plus-ag-installed?)) + +(defvar dumb-jump--rg-installed? 'unset) +(defun dumb-jump-rg-installed? () + "Return t if rg is installed." + (if (eq dumb-jump--rg-installed? 'unset) + (setq dumb-jump--rg-installed? + (let ((result (s-match "ripgrep \\([0-9]+\\)\\.\\([0-9]+\\).*" + (shell-command-to-string (concat dumb-jump-rg-cmd " --version"))))) + (when (equal (length result) 3) + (let ((major (string-to-number (nth 1 result))) + (minor (string-to-number (nth 2 result)))) + (or + (and (= major 0) (>= minor 10)) + (>= major 1)))))) + dumb-jump--rg-installed?)) + +(defvar dumb-jump--git-grep-installed? 'unset) +(defun dumb-jump-git-grep-installed? () + "Return t if git-grep is installed." + (if (eq dumb-jump--git-grep-installed? 'unset) + (setq dumb-jump--git-grep-installed? + (s-contains? "fatal: no pattern given" + (shell-command-to-string (concat dumb-jump-git-grep-cmd)))) + dumb-jump--git-grep-installed?)) + +(defvar dumb-jump--grep-installed? 'unset) +(defun dumb-jump-grep-installed? () + "Return 'gnu if GNU grep is installed, 'bsd if BSD grep is installed, and nil otherwise." + (if (eq dumb-jump--grep-installed? 'unset) + (let* ((version (shell-command-to-string (concat dumb-jump-grep-cmd " --version"))) + (variant (cond ((s-match "GNU grep" version) 'gnu) + ((s-match "[0-9]+\\.[0-9]+" version) 'bsd) + (t nil)))) + (setq dumb-jump--grep-installed? variant)) + dumb-jump--grep-installed?)) + +(defun dumb-jump-run-test (test cmd) + "Use TEST as the standard input for the CMD." + (with-temp-buffer + (insert test) + (shell-command-on-region (point-min) (point-max) cmd nil t) + (buffer-substring-no-properties (point-min) (point-max)))) + +(defun dumb-jump-run-test-temp-file (test thefile realcmd) + "Write content to the temporary file, run cmd on it, return result" + (with-temp-buffer + (insert test) + (write-file thefile nil) + (delete-region (point-min) (point-max)) + (shell-command realcmd t) + (delete-file thefile) + (buffer-substring-no-properties (point-min) (point-max)))) + +(defun dumb-jump-run-git-grep-test (test cmd) + "Use string TEST as input through a local, temporary file for CMD. +Because git grep must be given a file as input, not just a string." + (let ((thefile ".git.grep.test")) + (dumb-jump-run-test-temp-file test thefile (concat cmd " " thefile)))) + +(defun dumb-jump-run-ag-test (test cmd) + "Use TEST as input, but first write it into temporary file +and then run ag on it. The difference is that ag ignores multiline +matches when passed input from stdin, which is a crucial feature." + (let ((thefile ".ag.test")) + (dumb-jump-run-test-temp-file test thefile (concat cmd " " thefile)))) + +(defun dumb-jump-test-grep-rules (&optional run-not-tests) + "Test all the grep rules and return count of those that fail. +Optionally pass t for RUN-NOT-TESTS to see a list of all failed rules." + (let ((fail-tmpl "grep FAILURE '%s' %s in response '%s' | CMD: '%s' | rule: '%s'") + (variant (if (eq (dumb-jump-grep-installed?) 'gnu) 'gnu-grep 'grep))) + (-mapcat + (lambda (rule) + (-mapcat + (lambda (test) + (let* ((cmd (concat "grep -En -e " + (shell-quote-argument (dumb-jump-populate-regex (plist-get rule :regex) "test" variant)))) + (resp (dumb-jump-run-test test cmd))) + (when (or + (and (not run-not-tests) (not (s-contains? test resp))) + (and run-not-tests (> (length resp) 0))) + (list (format fail-tmpl (if run-not-tests "not" "") + test (if run-not-tests "IS unexpectedly" "NOT") resp cmd (plist-get rule :regex)))))) + (plist-get rule (if run-not-tests :not :tests)))) + (--filter (member "grep" (plist-get it :supports)) dumb-jump-find-rules)))) + +(defun dumb-jump-test-ag-rules (&optional run-not-tests) + "Test all the ag rules and return count of those that fail. +Optionally pass t for RUN-NOT-TESTS to see a list of all failed rules" + (let ((fail-tmpl "ag FAILURE '%s' %s in response '%s' | CMD: '%s' | rule: '%s'")) + (-mapcat + (lambda (rule) + (-mapcat + (lambda (test) + (let* ((cmd (concat "ag --nocolor --nogroup --nonumber " + (shell-quote-argument (dumb-jump-populate-regex (plist-get rule :regex) "test" 'ag)))) + (resp (dumb-jump-run-ag-test test cmd))) + (when (or + (and (not run-not-tests) (not (s-contains? test resp))) + (and run-not-tests (> (length resp) 0))) + (list (format fail-tmpl test (if run-not-tests "IS unexpectedly" "NOT") resp cmd rule))))) + (plist-get rule (if run-not-tests :not :tests)))) + (--filter (member "ag" (plist-get it :supports)) dumb-jump-find-rules)))) + +(defun dumb-jump-test-rg-rules (&optional run-not-tests) + "Test all the rg rules and return count of those that fail. +Optionally pass t for RUN-NOT-TESTS to see a list of all failed rules" + (let ((fail-tmpl "rg FAILURE '%s' %s in response '%s' | CMD: '%s' | rule: '%s'")) + (-mapcat + (lambda (rule) + (-mapcat + (lambda (test) + (let* ((cmd (concat "rg --color never --no-heading -U --pcre2 " + (shell-quote-argument (dumb-jump-populate-regex (plist-get rule :regex) "test" 'rg)))) + (resp (dumb-jump-run-test test cmd))) + (when (or + (and (not run-not-tests) (not (s-contains? test resp))) + (and run-not-tests (> (length resp) 0))) + (list (format fail-tmpl test (if run-not-tests "IS unexpectedly" "NOT") resp cmd rule))))) + (plist-get rule (if run-not-tests :not :tests)))) + (--filter (member "rg" (plist-get it :supports)) dumb-jump-find-rules)))) + +(defun dumb-jump-test-git-grep-rules (&optional run-not-tests) + "Test all the git grep rules and return count of those that fail. +Optionally pass t for RUN-NOT-TESTS to see a list of all failed rules" + (let ((fail-tmpl "rg FAILURE '%s' %s in response '%s' | CMD: '%s' | rule: '%s'")) + (-mapcat + (lambda (rule) + (-mapcat + (lambda (test) + (let* ((cmd (concat "git grep --color=never -h --untracked -E " + (shell-quote-argument (dumb-jump-populate-regex (plist-get rule :regex) "test" 'git-grep)))) + (resp (dumb-jump-run-git-grep-test test cmd))) + (when (or + (and (not run-not-tests) (not (s-contains? test resp))) + (and run-not-tests (> (length resp) 0))) + (list (format fail-tmpl test (if run-not-tests "IS unexpectedly" "NOT") resp cmd rule))))) + (plist-get rule (if run-not-tests :not :tests)))) + (--filter (member "grep" (plist-get it :supports)) dumb-jump-find-rules)))) + +(defun dumb-jump-message (str &rest args) + "Log message STR with ARGS to the *Messages* buffer if not using dumb-jump-quiet." + (when (not dumb-jump-quiet) + (apply 'message str args)) + nil) + +(defmacro dumb-jump-debug-message (&rest exprs) + "Generate a debug message to print all expressions EXPRS." + (declare (indent defun)) + (let ((i 5) frames frame) + ;; based on https://emacs.stackexchange.com/a/2312 + (while (setq frame (backtrace-frame i)) + (push frame frames) + (cl-incf i)) + ;; this is a macro-expanded version of the code in the stackexchange + ;; code from above. This version should work on emacs-24.3, since it + ;; doesn't depend on thread-last. + (let* ((frame (cl-find-if + (lambda (frame) + (ignore-errors + (and (car frame) + (eq (caaddr frame) + 'defalias)))) + (reverse frames))) + (func (cl-cadadr (cl-caddr frame))) + (defun-name (symbol-name func))) + (with-temp-buffer + (insert "DUMB JUMP DEBUG `") + (insert defun-name) + (insert "` START\n----\n\n") + (dolist (expr exprs) + (insert (prin1-to-string expr) ":\n\t%s\n\n")) + (insert "\n-----\nDUMB JUMP DEBUG `") + (insert defun-name) + (insert "` END\n-----") + `(when dumb-jump-debug + (dumb-jump-message + ,(buffer-string) + ,@exprs)))))) + +(defun dumb-jump-get-point-context (line func cur-pos) + "Get the LINE context to the left and right of FUNC using CUR-POS as hint." + (let ((loc (or (cl-search func line :start2 cur-pos) 0))) + (list :left (substring line 0 loc) + :right (substring line (+ loc (length func)))))) + +(defun dumb-jump-to-selected (results choices selected) + "With RESULTS use CHOICES to find the SELECTED choice from multiple options." + (let* ((result-index (--find-index (string= selected it) choices)) + (result (when result-index + (nth result-index results)))) + (when result + (dumb-jump-result-follow result)))) + +(defun dumb-jump-helm-persist-action (candidate) + "Previews CANDIDATE in a temporary buffer displaying the file at the matched line. +\\ +This is the persistent action (\\[helm-execute-persistent-action]) for helm." + (let* ((file (plist-get candidate :path)) + (line (plist-get candidate :line)) + (default-directory-old default-directory)) + (switch-to-buffer (get-buffer-create " *helm dumb jump persistent*")) + (setq default-directory default-directory-old) + (fundamental-mode) + (erase-buffer) + (insert-file-contents file) + (let ((buffer-file-name file)) + (set-auto-mode) + (font-lock-fontify-region (point-min) (point-max)) + (goto-char (point-min)) + (forward-line (1- line))))) + +(defun dumb-jump--format-result (proj result) + (format "%s:%s: %s" + (s-replace proj "" (plist-get result :path)) + (plist-get result :line) + (s-trim (plist-get result :context)))) + +(defun dumb-jump-ivy-jump-to-selected (results choices _proj) + "Offer CHOICES as candidates through `ivy-read', then execute +`dumb-jump-result-follow' on the selected choice. Ignore _PROJ." + (ivy-read "Jump to: " (-zip choices results) + :action (lambda (cand) + (dumb-jump-result-follow (cdr cand))) + :caller 'dumb-jump-ivy-jump-to-selected)) + +(defun dumb-jump-prompt-user-for-choice (proj results) + "Put a PROJ's list of RESULTS in a 'popup-menu' (or helm/ivy) +for user to select. Filters PROJ path from files for display." + (let ((choices (--map (dumb-jump--format-result proj it) results))) + (cond + ((eq dumb-jump-selector 'completing-read) + (dumb-jump-to-selected results choices (completing-read "Jump to: " choices))) + ((and (eq dumb-jump-selector 'ivy) (fboundp 'ivy-read)) + (funcall dumb-jump-ivy-jump-to-selected-function results choices proj)) + ((and (eq dumb-jump-selector 'helm) (fboundp 'helm)) + (helm :sources + (helm-make-source "Jump to: " 'helm-source-sync + :action '(("Jump to match" . dumb-jump-result-follow)) + :candidates (-zip choices results) + :persistent-action 'dumb-jump-helm-persist-action) + :buffer "*helm dumb jump choices*")) + (t + (dumb-jump-to-selected results choices (popup-menu* choices)))))) + +(defun dumb-jump-get-project-root (filepath) + "Keep looking at the parent dir of FILEPATH until a denoter file/dir is found." + (s-chop-suffix + "/" + (expand-file-name + (or + dumb-jump-project + (locate-dominating-file filepath #'dumb-jump-get-config) + dumb-jump-default-project)))) + +(defun dumb-jump-get-config (dir) + "If a project denoter is in DIR then return it, otherwise +nil. However, if DIR contains a `.dumbjumpignore' it returns nil +to keep looking for another root." + (if (file-exists-p (expand-file-name ".dumbjumpignore" dir)) + nil + (car (--filter + (file-exists-p (expand-file-name it dir)) + dumb-jump-project-denoters)))) + +(defun dumb-jump-get-language (file) + "Get language from FILE extension and then fallback to using 'major-mode' name." + (let* ((language (or (dumb-jump-get-language-from-mode) + (dumb-jump-get-language-by-filename file) + (dumb-jump-get-mode-base-name)))) + ; src edit buffer ? org-edit-src-exit + (if (and (fboundp 'org-src-edit-buffer-p) + (org-src-edit-buffer-p)) + (progn (setq language "org") + (org-edit-src-exit) + (if (version< org-version "9") + (save-buffer)))) + (if (string= language "org") + (setq language (dumb-jump-get-language-in-org))) + (if (member language (-distinct + (--map (plist-get it :language) + dumb-jump-find-rules))) + language + (format ".%s file" (or (file-name-extension file) ""))))) + +(defun dumb-jump-get-language-in-org () + "In org mode, if inside a src block return +associated language or org when outside a src block." + (let ((lang (nth 0 (org-babel-get-src-block-info)))) +;; if lang exists then create a composite language + (if lang + (dumb-jump-make-composite-language + "org" + (if (dumb-jump-get-language-from-aliases lang) + (dumb-jump-get-language-from-aliases lang) lang) + "org" "org" "org") + "org"))) + +(defun dumb-jump-add-language-to-proplist (newlang proplist lang) + "Return nil if NEWLANG is already in PROPLIST or (if not) +return a new proplist. The new proplis is PROPLIS +where a NEWLANG plist(s) is (are) added to PROPLIST. +The plist(s) value of NEWLANG is (are) copied from +those of LANG and LANG is replaced by NEWLANG." + (unless (--filter (string= newlang (plist-get it :language)) + proplist) + (--splice + (string= lang (plist-get it :language)) + (list it (plist-put (copy-tree it) :language newlang)) + proplist))) + +(defun dumb-jump-make-composite-language (mode lang extension agtype rgtype) + "Concat one MODE (usually the string org) with a LANG (c or python or etc) +to make a composite language of the form cPLUSorg or pythonPLUSorg or etc. +Modify `dumb-jump-find-rules' and `dumb-jump-language-file-exts' accordingly +(using EXTENSION AGTYPE RGTYPE)" + (let* ((complang (concat lang "PLUS" mode)) + (alreadyextension (--filter (and + (string= complang (plist-get it :language)) + (string= extension (plist-get it :ext)) + (string= agtype (plist-get it :agtype)) + (string= rgtype (plist-get it :rgtype))) + dumb-jump-language-file-exts)) + (newfindrule (dumb-jump-add-language-to-proplist complang dumb-jump-find-rules lang)) + (newfileexts (dumb-jump-add-language-to-proplist complang dumb-jump-language-file-exts lang))) + ;; add (if needed) composite language to dumb-jump-find-rules + (when newfindrule + (set-default 'dumb-jump-find-rules newfindrule)) + ;; add (if needed) composite language to dumb-jump-language-file-exts + (unless dumb-jump-search-type-org-only-org + (when newfileexts + (set-default 'dumb-jump-language-file-exts newfileexts))) + ;; add (if needed) a new extension to dumb-jump-language-file-exts + (unless alreadyextension + (set-default 'dumb-jump-language-file-exts + (cons `(:language ,complang :ext ,extension :agtype ,agtype :rgtype ,rgtype) + dumb-jump-language-file-exts))) + complang)) + +(defun dumb-jump-get-language-from-aliases (lang) + "Extract the lang from LANG and aliases." + (assoc-default lang '(("sh" . "shell") ("shell" . "shell") ("cperl" . "perl") + ("matlab" . "matlab") ("octave" . "matlab") + ("emacs-lisp" . "elisp") ("elisp" . "elisp") + ("R" . "r") ("r" . "r")))) + +(defun dumb-jump-get-mode-base-name () + "Get the base name of the mode." + (s-replace "-mode" "" (symbol-name major-mode))) + +(defun dumb-jump-get-language-from-mode () + "Extract the language from the 'major-mode' name. Currently just everything before '-mode'." + (let ((m (dumb-jump-get-mode-base-name))) + (dumb-jump-get-language-from-aliases m))) + +(defun dumb-jump-get-language-by-filename (file) + "Get the programming language from the FILE." + (let* ((filename (if (s-ends-with? ".gz" file) + (file-name-sans-extension file) + file)) + (result (--filter + (s-ends-with? (concat "." (plist-get it :ext)) filename) + dumb-jump-language-file-exts))) + (when (and result (eq (length result) 1)) + (plist-get (car result) :language)))) + +(defun dumb-jump-issue-result (issue) + "Return a result property list with the ISSUE set as :issue property symbol." + `(:results nil :lang nil :symbol nil :ctx-type nil :file nil :root nil :issue ,(intern issue))) + +(defun dumb-jump-get-results (&optional prompt) + "Run dumb-jump-fetch-results if searcher installed, buffer is saved, and there's a symbol under point." + (cond + ((not (or (dumb-jump-ag-installed?) + (dumb-jump-rg-installed?) + (dumb-jump-git-grep-installed?) + (dumb-jump-grep-installed?))) + (dumb-jump-issue-result "nogrep")) + ((or (string= (buffer-name) "*shell*") + (string= (buffer-name) "*eshell*")) + (dumb-jump-fetch-shell-results prompt)) + ((and (not prompt) (not (region-active-p)) (not (thing-at-point 'symbol))) + (dumb-jump-issue-result "nosymbol")) + (t + (dumb-jump-fetch-file-results prompt)))) + +(defun dumb-jump-fetch-shell-results (&optional prompt) + (let* ((cur-file (buffer-name)) + (proj-root (dumb-jump-get-project-root default-directory)) + (proj-config (dumb-jump-get-config proj-root)) + (config (when (s-ends-with? ".dumbjump" proj-config) + (dumb-jump-read-config proj-root proj-config))) + (lang (or (plist-get config :language) + (car (dumb-jump-get-lang-by-shell-contents (buffer-name)))))) + (dumb-jump-fetch-results cur-file proj-root lang config prompt))) + +(defun dumb-jump-fetch-file-results (&optional prompt) + (let* ((cur-file (or (buffer-file-name) "")) + (proj-root (dumb-jump-get-project-root cur-file)) + (proj-config (dumb-jump-get-config proj-root)) + (config (when (s-ends-with? ".dumbjump" proj-config) + (dumb-jump-read-config proj-root proj-config))) + (lang (or (plist-get config :language) + (dumb-jump-get-language cur-file)))) + (dumb-jump-fetch-results cur-file proj-root lang config prompt))) + +(defun dumb-jump-process-symbol-by-lang (lang look-for) + "Process LANG's LOOK-FOR. For instance, clojure needs namespace part removed." + (cond + ((and (string= lang "commonlisp") (s-contains? ":" look-for) (not (s-starts-with? ":" look-for))) + (nth 1 (s-split ":" look-for 'omit-nulls))) + ((and (string= lang "clojure") (s-contains? "/" look-for)) + (nth 1 (s-split "/" look-for))) + ((and (string= lang "fennel") (s-contains? "." look-for)) + (-last-item (s-split "\\." look-for))) + ((and (string= lang "ruby") (s-contains? "::" look-for)) + (-last-item (s-split "::" look-for))) + ((and (or (string= lang "ruby") (string= lang "crystal")) (s-starts-with? ":" look-for)) + (s-chop-prefix ":" look-for)) + ((and (string= lang "systemverilog") (s-starts-with? "`" look-for)) + (s-chop-prefix "`" look-for)) + (t + look-for))) + +(defun dumb-jump-get-point-line () + "Get line at point." + (if (version< emacs-version "24.4") + (thing-at-point 'line) + (thing-at-point 'line t))) + +(defun dumb-jump-get-point-symbol () + "Get symbol at point." + (if (region-active-p) + (buffer-substring-no-properties (region-beginning) (region-end)) + (if (version< emacs-version "24.4") + (thing-at-point 'symbol) + (thing-at-point 'symbol t)))) + +(defun dumb-jump--get-symbol-start () + "Get the start of symbol at point" + (- (if (region-active-p) + (region-beginning) + (car (bounds-of-thing-at-point 'symbol))) + (line-beginning-position))) + +(defun dumb-jump-get-lang-by-shell-contents (buffer) + "Return languages in BUFFER by checking if file extension is mentioned." + (let* ((buffer-contents (with-current-buffer buffer + (buffer-string))) + + (found (--filter (s-match (concat "\\." (plist-get it :ext) "\\b") buffer-contents) + dumb-jump-language-file-exts))) + (--map (plist-get it :language) found))) + +(defun dumb-jump-fetch-results (cur-file proj-root lang _config &optional prompt) + "Return a list of results based on current file context and calling grep/ag. +CUR-FILE is the path of the current buffer. +PROJ-ROOT is that file's root project directory. +LANG is a string programming language with CONFIG a property list +of project configuration." + (let* ((cur-line-num (line-number-at-pos)) + (proj-config (dumb-jump-get-config proj-root)) + (config (when (s-ends-with? ".dumbjump" proj-config) + (dumb-jump-read-config proj-root proj-config))) + (found-symbol (or prompt (dumb-jump-get-point-symbol))) + (look-for (dumb-jump-process-symbol-by-lang lang found-symbol)) + (pt-ctx (if prompt + (get-text-property 0 :dumb-jump-ctx prompt) + (dumb-jump-get-point-context + (dumb-jump-get-point-line) + look-for + (dumb-jump--get-symbol-start)))) + (ctx-type + (dumb-jump-get-ctx-type-by-language lang pt-ctx)) + + (gen-funcs (dumb-jump-pick-grep-variant proj-root)) + (parse-fn (plist-get gen-funcs :parse)) + (generate-fn (plist-get gen-funcs :generate)) + (searcher (plist-get gen-funcs :searcher)) + + (regexes (dumb-jump-get-contextual-regexes lang ctx-type searcher)) + + (exclude-paths (when config (plist-get config :exclude))) + (include-paths (when config (plist-get config :include))) + ; we will search proj root and all include paths + (search-paths (-distinct (-concat (list proj-root) include-paths))) + ; run command for all + (raw-results (--mapcat + ;; TODO: should only pass exclude paths to actual project root + (dumb-jump-run-command look-for it regexes lang exclude-paths cur-file + cur-line-num parse-fn generate-fn) + search-paths)) + + (results (delete-dups (--map (plist-put it :target look-for) raw-results)))) + + `(:results ,results :lang ,(if (null lang) "" lang) :symbol ,look-for :ctx-type ,(if (null ctx-type) "" ctx-type) :file ,cur-file :root ,proj-root))) + +;;;###autoload +(defun dumb-jump-back () + "Jump back to where the last jump was done." + (interactive) + (with-demoted-errors "Error running `dumb-jump-before-jump-hook': %S" + (run-hooks 'dumb-jump-before-jump-hook)) + (pop-tag-mark) + (with-demoted-errors "Error running `dumb-jump-after-jump-hook': %S" + (run-hooks 'dumb-jump-after-jump-hook))) + +;;;###autoload +(defun dumb-jump-quick-look () + "Run dumb-jump-go in quick look mode. That is, show a tooltip of where it would jump instead." + (interactive) + (dumb-jump-go t)) + +;;;###autoload +(defun dumb-jump-go-other-window () + "Like 'dumb-jump-go' but use 'find-file-other-window' instead of 'find-file'." + (interactive) + (let ((dumb-jump-window 'other)) + (dumb-jump-go))) + +;;;###autoload +(defun dumb-jump-go-current-window () + "Like dumb-jump-go but always use 'find-file'." + (interactive) + (let ((dumb-jump-window 'current)) + (dumb-jump-go))) + +;;;###autoload +(defun dumb-jump-go-prefer-external () + "Like dumb-jump-go but prefer external matches from the current file." + (interactive) + (dumb-jump-go nil t)) + +;;;###autoload +(defun dumb-jump-go-prompt () + "Like dumb-jump-go but prompts for function instead of using under point" + (interactive) + (dumb-jump-go nil nil (read-from-minibuffer "Jump to: "))) + +;;;###autoload +(defun dumb-jump-go-prefer-external-other-window () + "Like dumb-jump-go-prefer-external but use 'find-file-other-window' instead of 'find-file'." + (interactive) + (let ((dumb-jump-window 'other)) + (dumb-jump-go-prefer-external))) + +;;;###autoload +(defun dumb-jump-go (&optional use-tooltip prefer-external prompt) + "Go to the function/variable declaration for thing at point. +When USE-TOOLTIP is t a tooltip jump preview will show instead. +When PREFER-EXTERNAL is t it will sort external matches before +current file." + (interactive "P") + (let* ((start-time (float-time)) + (info (dumb-jump-get-results prompt)) + (end-time (float-time)) + (fetch-time (- end-time start-time)) + (results (plist-get info :results)) + (look-for (or prompt (plist-get info :symbol))) + (proj-root (plist-get info :root)) + (issue (plist-get info :issue)) + (lang (plist-get info :lang)) + (result-count (length results))) + (when (> fetch-time dumb-jump-max-find-time) + (dumb-jump-message + "Took over %ss to find '%s'. Please install ag or rg, or add a .dumbjump file to '%s' with path exclusions" + (number-to-string dumb-jump-max-find-time) look-for proj-root)) + (cond + ((eq issue 'nogrep) + (dumb-jump-message "Please install ag, rg, git grep or grep!")) + ((eq issue 'nosymbol) + (dumb-jump-message "No symbol under point.")) + ((s-ends-with? " file" lang) + (dumb-jump-message "Could not find rules for '%s'." lang)) + ((= result-count 1) + (dumb-jump-result-follow (car results) use-tooltip proj-root)) + ((> result-count 1) + ;; multiple results so let the user pick from a list + ;; unless the match is in the current file + (dumb-jump-handle-results results (plist-get info :file) proj-root (plist-get info :ctx-type) + look-for use-tooltip prefer-external lang)) + ((= result-count 0) + (dumb-jump-message "'%s' %s %s declaration not found." look-for (if (s-blank? lang) "with unknown language so" lang) (plist-get info :ctx-type)))))) + +(defcustom dumb-jump-language-comments + '((:comment "//" :language "c++") + (:comment ";" :language "elisp") + (:comment ";" :language "commonlisp") + (:comment "//" :language "javascript") + (:comment "//" :language "typescript") + (:comment "//" :language "dart") + (:comment "--" :language "haskell") + (:comment "--" :language "lua") + (:comment "//" :language "rust") + (:comment "#" :language "julia") + (:comment "//" :language "objc") + (:comment "//" :language "csharp") + (:comment "//" :language "java") + (:comment ";" :language "clojure") + (:comment "#" :language "coffeescript") + (:comment "//" :language "faust") + (:comment ";" :language "fennel") + (:comment "!" :language "fortran") + (:comment "//" :language "go") + (:comment "//" :language "zig") + (:comment "#" :language "perl") + (:comment "#" :language "tcl") + (:comment "//" :language "php") + (:comment "#" :language "python") + (:comment "%" :language "matlab") + (:comment "#" :language "r") + (:comment ";" :language "racket") + (:comment "#" :language "ruby") + (:comment "#" :language "crystal") + (:comment "#" :language "nim") + (:comment "#" :language "nix") + (:comment "//" :language "scala") + (:comment ";" :language "scheme") + (:comment "#" :language "janet") + (:comment "#" :language "shell") + (:comment "//" :language "solidity") + (:comment "//" :language "swift") + (:comment "#" :language "elixir") + (:comment "%" :language "erlang") + (:comment "%" :language "tex") + (:comment "//" :language "systemverilog") + (:comment "--" :language "vhdl") + (:comment "//" :language "scss") + (:comment "//" :language "pascal") + (:comment "//" :language "protobuf") + (:comment "#" :language "hcl") + (:comment "//" :language "apex")) + "List of one-line comments organized by language." + :group 'dumb-jump + :type + '(repeat + (plist + :options ((:comment string) + (:language string))))) + +(defun dumb-jump-get-comment-by-language (lang) + "Yields the one-line comment for the given LANG." + (let* ((entries (-distinct + (--filter (string= (plist-get it :language) lang) + dumb-jump-language-comments)))) + (if (= 1 (length entries)) + (plist-get (car entries) :comment) + nil))) + +(defun dumb-jump-filter-no-start-comments (results lang) + "Filter out RESULTS with a :context that starts with a comment +given the LANG of the current file." + (let ((comment (dumb-jump-get-comment-by-language lang))) + (if comment + (-concat + (--filter (not (s-starts-with? comment (s-trim (plist-get it :context)))) results)) + results))) + +(defun dumb-jump-handle-results + (results cur-file proj-root ctx-type look-for use-tooltip prefer-external &optional language) + "Handle the searchers results. +RESULTS is a list of property lists with the searcher's results. +CUR-FILE is the current file within PROJ-ROOT. +CTX-TYPE is a string of the current context. +LOOK-FOR is the symbol we're jumping for. +USE-TOOLTIP shows a preview instead of jumping. +PREFER-EXTERNAL will sort current file last +LANGUAGE is an optional language to pass to `dumb-jump-process-results'." + (let* ((processed (dumb-jump-process-results results cur-file proj-root ctx-type look-for use-tooltip prefer-external language)) + (results (plist-get processed :results)) + (do-var-jump (plist-get processed :do-var-jump)) + (var-to-jump (plist-get processed :var-to-jump)) + (match-cur-file-front (plist-get processed :match-cur-file-front))) + (dumb-jump-debug-message + look-for + ctx-type + var-to-jump + (pp-to-string match-cur-file-front) + (pp-to-string results) + prefer-external + proj-root + cur-file) + (cond + (use-tooltip ;; quick-look mode + (popup-menu* (--map (dumb-jump--format-result proj-root it) results))) + (do-var-jump + (dumb-jump-result-follow var-to-jump use-tooltip proj-root)) + (t + (dumb-jump-prompt-user-for-choice proj-root match-cur-file-front))))) + +(defun dumb-jump-process-results + (results cur-file proj-root ctx-type _look-for _use-tooltip prefer-external &optional language) + "Process (filter, sort, ...) the searchers results. +RESULTS is a list of property lists with the searcher's results. +CUR-FILE is the current file within PROJ-ROOT. +CTX-TYPE is a string of the current context. +LOOK-FOR is the symbol we're jumping for. +USE-TOOLTIP shows a preview instead of jumping. +PREFER-EXTERNAL will sort current file last. +LANGUAGE is the optional given language, if nil it will be found by +dumb-jump-get-language-by-filename." + "Figure which of the RESULTS to jump to. Favoring the CUR-FILE" + (let* ((lang (if language language (dumb-jump-get-language-by-filename cur-file))) + (match-sorted (-sort (lambda (x y) (< (plist-get x :diff) (plist-get y :diff))) results)) + (match-no-comments (dumb-jump-filter-no-start-comments match-sorted lang)) + + ;; Find the relative current file path by the project root. In some cases the results will + ;; not be absolute but relative and the "current file" filters must match in both + ;; cases. Also works when current file is in an arbitrary sub folder. + (rel-cur-file + (cond ((and (s-starts-with? proj-root cur-file) + (s-starts-with? default-directory cur-file)) + (substring cur-file (length default-directory) (length cur-file))) + + ((and (s-starts-with? proj-root cur-file) + (not (s-starts-with? default-directory cur-file))) + (substring cur-file (1+ (length proj-root)) (length cur-file))) + + (t + cur-file))) + + ;; Moves current file results to the front of the list, unless PREFER-EXTERNAL then put + ;; them last. + (match-cur-file-front + (if (not prefer-external) + (-concat + (--filter (and (> (plist-get it :diff) 0) + (or (string= (plist-get it :path) cur-file) + (string= (plist-get it :path) rel-cur-file))) + match-no-comments) + (--filter (and (<= (plist-get it :diff) 0) + (or (string= (plist-get it :path) cur-file) + (string= (plist-get it :path) rel-cur-file))) + match-no-comments) + + ;; Sort non-current files by path length so the nearest file is more likely to be + ;; sorted higher to the top. Also sorts by line number for sanity. + (-sort (lambda (x y) + (and (< (plist-get x :line) (plist-get y :line)) + (< (length (plist-get x :path)) (length (plist-get y :path))))) + (--filter (not (or (string= (plist-get it :path) cur-file) + (string= (plist-get it :path) rel-cur-file))) + match-no-comments))) + (-concat + (-sort (lambda (x y) + (and (< (plist-get x :line) (plist-get y :line)) + (< (length (plist-get x :path)) (length (plist-get y :path))))) + (--filter (not (or (string= (plist-get it :path) cur-file) + (string= (plist-get it :path) rel-cur-file))) + match-no-comments)) + (--filter (or (string= (plist-get it :path) cur-file) + (string= (plist-get it :path) rel-cur-file)) + match-no-comments)))) + + (matches + (if (not prefer-external) + (-distinct + (append (dumb-jump-current-file-results cur-file match-cur-file-front) + (dumb-jump-current-file-results rel-cur-file match-cur-file-front))) + match-cur-file-front)) + + (var-to-jump (car matches)) + ;; TODO: handle if ctx-type is null but ALL results are variable + + ;; When non-aggressive it should only jump when there is only one match, regardless of + ;; context. + (do-var-jump + (and (or dumb-jump-aggressive + (= (length match-cur-file-front) 1)) + (or (= (length matches) 1) + (string= ctx-type "variable") + (string= ctx-type "")) + var-to-jump))) + + (list :results results + :do-var-jump do-var-jump + :var-to-jump var-to-jump + :match-cur-file-front match-cur-file-front))) + +(defun dumb-jump-read-config (root config-file) + "Load and return options (exclusions, inclusions, etc). +Ffrom the ROOT project CONFIG-FILE." + (with-temp-buffer + (insert-file-contents (expand-file-name config-file root)) + (let ((local-root (if (file-remote-p root) + (tramp-file-name-localname + (tramp-dissect-file-name root)) + root)) + include exclude lang) + (while (not (eobp)) + (cond ((looking-at "^language \\\(.+\\\)") + (setq lang (match-string 1))) + ((looking-at "^\\+\\(.+\\)") + (push (expand-file-name (match-string 1) local-root) + include)) + ((looking-at "^-/?\\(.+\\)") + (push (expand-file-name (match-string 1) local-root) + exclude))) + (forward-line)) + (list :exclude (nreverse exclude) + :include (nreverse include) + :language lang)))) + +(defun dumb-jump-file-modified-p (path) + "Check if PATH is currently open in Emacs and has a modified buffer." + (interactive) + (--any? + (and (buffer-modified-p it) + (buffer-file-name it) + (file-exists-p (buffer-file-name it)) + (file-equal-p (buffer-file-name it) path)) + (buffer-list))) + +(defun dumb-jump-result-follow (result &optional use-tooltip proj) + "Take the RESULT to jump to and record the jump, for jumping back, and then trigger jump. If dumb-jump-confirm-jump-to-modified-file is t, prompt if we should continue if destination has been modified. If it is nil, display a warning." + (if (dumb-jump-file-modified-p (plist-get result :path)) + (let ((target-file (plist-get result :path))) + (if dumb-jump-confirm-jump-to-modified-file + (when (y-or-n-p (concat target-file " has been modified so we may have the wrong location. Continue?")) + (dumb-jump--result-follow result use-tooltip proj)) + (progn (message + "Warning: %s has been modified so we may have the wrong location." + target-file) + (dumb-jump--result-follow result use-tooltip proj)))) + (dumb-jump--result-follow result use-tooltip proj))) + +(defun dumb-jump--result-follow (result &optional use-tooltip proj) + "Take the RESULT to jump to and record the jump, for jumping back, and then trigger jump." + (let* ((target-boundary (s-matched-positions-all + (concat "\\b" (regexp-quote (plist-get result :target)) "\\b") + (plist-get result :context))) + ;; column pos is either via tpos from ag or by using the regex above or last using old s-index-of + (pos (if target-boundary + (car (car target-boundary)) + (s-index-of (plist-get result :target) (plist-get result :context)))) + + (result-path (plist-get result :path)) + + ;; Return value is either a string like "/ssh:user@1.2.3.4:" or nil + (tramp-path-prefix (file-remote-p default-directory)) + + ;; If result-path is an absolute path, the prefix is added to the head of it, + ;; or result-path is added to the end of default-directory + (path-for-tramp (when (and result-path tramp-path-prefix) + (if (file-name-absolute-p result-path) + (concat tramp-path-prefix result-path) + (concat default-directory result-path)))) + + (thef (or path-for-tramp result-path)) + (line (plist-get result :line))) + (when thef + (if use-tooltip + (popup-tip (dumb-jump--format-result proj result)) + (dumb-jump-goto-file-line thef line pos))) + ;; return the file for test + thef)) + + +(defun dumb-jump-goto-file-line (thefile theline pos) + "Open THEFILE and go line THELINE" + (if (fboundp 'xref-push-marker-stack) + (xref-push-marker-stack) + (ring-insert find-tag-marker-ring (point-marker))) + + (with-demoted-errors "Error running `dumb-jump-before-jump-hook': %S" + (run-hooks 'dumb-jump-before-jump-hook)) + + (let* ((visible-buffer (find-buffer-visiting thefile)) + (visible-window (when visible-buffer (get-buffer-window visible-buffer)))) + (cond + ((and visible-window dumb-jump-use-visible-window) + (select-window visible-window)) + ((eq dumb-jump-window 'other) + (find-file-other-window thefile)) + (t (find-file thefile)))) + + (goto-char (point-min)) + (forward-line (1- theline)) + (forward-char pos) + (with-demoted-errors "Error running `dumb-jump-after-jump-hook': %S" + (run-hooks 'dumb-jump-after-jump-hook))) + +(defun dumb-jump-current-file-results (path results) + "Return the PATH's RESULTS." + (let ((matched (--filter (string= path (plist-get it :path)) results))) + matched)) + +(defun dumb-jump-generators-by-searcher (searcher) + "For a SEARCHER it yields a response parser, a command +generator function, an installed? function, and the corresponding +searcher symbol." + (cond ((equal 'git-grep searcher) + `(:parse ,'dumb-jump-parse-git-grep-response + :generate ,'dumb-jump-generate-git-grep-command + :installed ,'dumb-jump-git-grep-installed? + :searcher ,searcher)) + ((equal 'ag searcher) + `(:parse ,'dumb-jump-parse-ag-response + :generate ,'dumb-jump-generate-ag-command + :installed ,'dumb-jump-ag-installed? + :searcher ,searcher)) + ((equal 'git-grep-plus-ag searcher) + `(:parse ,'dumb-jump-parse-ag-response + :generate ,'dumb-jump-generate-git-grep-plus-ag-command + :installed ,'dumb-jump-git-grep-plus-ag-installed? + :searcher ,searcher)) + ((equal 'rg searcher) + `(:parse ,'dumb-jump-parse-rg-response + :generate ,'dumb-jump-generate-rg-command + :installed ,'dumb-jump-rg-installed? + :searcher ,searcher)) + ((equal 'gnu-grep searcher) + `(:parse ,'dumb-jump-parse-grep-response + :generate ,'dumb-jump-generate-gnu-grep-command + :installed ,'dumb-jump-grep-installed? + :searcher ,searcher)) + ((equal 'grep searcher) + `(:parse ,'dumb-jump-parse-grep-response + :generate ,'dumb-jump-generate-grep-command + :installed ,'dumb-jump-grep-installed? + :searcher ,searcher)))) + +(defun dumb-jump-pick-grep-variant (&optional proj-root) + (cond + ;; If `dumb-jump-force-searcher' is not nil then use that searcher. + (dumb-jump-force-searcher + (dumb-jump-generators-by-searcher dumb-jump-force-searcher)) + + ;; If project root has a .git then use git-grep if installed. + ((and proj-root + (dumb-jump-git-grep-installed?) + (file-exists-p (expand-file-name ".git" proj-root))) + (dumb-jump-generators-by-searcher 'git-grep)) + + ;; If `dumb-jump-prefer-searcher' is not nil then use if installed. + ((and dumb-jump-prefer-searcher + (funcall (plist-get (dumb-jump-generators-by-searcher dumb-jump-prefer-searcher) + :installed))) + (dumb-jump-generators-by-searcher dumb-jump-prefer-searcher)) + + ;; Fallback searcher order. + ((dumb-jump-ag-installed?) + (dumb-jump-generators-by-searcher 'ag)) + ((dumb-jump-rg-installed?) + (dumb-jump-generators-by-searcher 'rg)) + ((eq (dumb-jump-grep-installed?) 'gnu) + (dumb-jump-generators-by-searcher 'gnu-grep)) + (t + (dumb-jump-generators-by-searcher 'grep)))) + +(defun dumb-jump-shell-command-switch () + "Yields the shell command switch to use for the current + `shell-file-name' in order to not load the shell profile/RC for + speeding up things." + (let ((base-name (downcase (file-name-base shell-file-name)))) + (cond + ((or (string-equal "zsh" base-name) + (string-equal "csh" base-name) + (string-equal "tcsh" base-name)) + "-icf") + + ((string-equal "bash" base-name) + "-c") + + (t + shell-command-switch)))) + +(defconst dumb-jump--case-insensitive-languages + '("commonlisp")) + +;; TODO: rename dumb-jump-run-definition-command +(defun dumb-jump-run-command + (look-for proj regexes lang exclude-args cur-file line-num parse-fn generate-fn) + "Run the grep command based on the needle LOOK-FOR in the directory TOSEARCH" + (let* ((proj-root (if (file-remote-p proj) + (directory-file-name + (tramp-file-name-localname (tramp-dissect-file-name proj))) + proj)) + (cmd (funcall generate-fn look-for cur-file proj-root regexes lang exclude-args)) + (shell-command-switch (dumb-jump-shell-command-switch)) + (rawresults (shell-command-to-string cmd))) + + (dumb-jump-debug-message cmd rawresults) + (when (and (s-blank? rawresults) dumb-jump-fallback-search) + (setq regexes (list dumb-jump-fallback-regex)) + (setq cmd (funcall generate-fn look-for cur-file proj-root regexes lang exclude-args)) + (setq rawresults (shell-command-to-string cmd)) + (dumb-jump-debug-message cmd rawresults)) + (unless (s-blank? cmd) + (let ((results (funcall parse-fn rawresults cur-file line-num)) + (ignore-case (member lang dumb-jump--case-insensitive-languages))) + (--filter (s-contains? look-for (plist-get it :context) ignore-case) results))))) + +(defun dumb-jump-parse-response-line (resp-line cur-file) + "Parse a search program's single RESP-LINE for CUR-FILE into a list of (path line context)." + (let* ((parts (--remove (string= it "") + (s-split "\\(?:^\\|:\\)[0-9]+:" resp-line))) + (line-num-raw (s-match "\\(?:^\\|:\\)\\([0-9]+\\):" resp-line))) + + (cond + ;; fixes rare bug where context is blank but file is defined "/somepath/file.txt:14:" + ;; OR: (and (= (length parts) 1) (file-name-exists (nth 0 parts))) + ((s-match ":[0-9]+:$" resp-line) + nil) + ((and parts line-num-raw) + (if (= (length parts) 2) + (list (let ((path (expand-file-name (nth 0 parts)))) + (if (file-name-absolute-p (nth 0 parts)) + path + (file-relative-name path))) + (nth 1 line-num-raw) (nth 1 parts)) + ; this case is when they are searching a particular file... + (list (let ((path (expand-file-name cur-file))) + (if (file-name-absolute-p cur-file) + path + (file-relative-name path))) + (nth 1 line-num-raw) (nth 0 parts))))))) + +(defun dumb-jump-parse-response-lines (parsed cur-file cur-line-num) + "Turn PARSED response lines into a list of property lists. Using CUR-FILE and CUR-LINE-NUM to exclude jump origin." + (let* ((records (--mapcat (when it + (let* ((line-num (string-to-number (nth 1 it))) + (diff (- cur-line-num line-num))) + (list `(:path ,(nth 0 it) :line ,line-num :context ,(nth 2 it) :diff ,diff)))) + parsed)) + (results (-non-nil records))) + (--filter + (not (and + (string= (plist-get it :path) cur-file) + (= (plist-get it :line) cur-line-num))) + results))) + +(defun dumb-jump-parse-grep-response (resp cur-file cur-line-num) + "Takes a grep response RESP and parses into a list of plists." + (let* ((resp-no-warnings (--filter (and (not (s-starts-with? "grep:" it)) + (not (s-contains? "No such file or" it))) + (s-split "\n" (s-trim resp)))) + (parsed (--map (dumb-jump-parse-response-line it cur-file) resp-no-warnings))) + (dumb-jump-parse-response-lines parsed cur-file cur-line-num))) + +(defun dumb-jump-parse-ag-response (resp cur-file cur-line-num) + "Takes a ag response RESP and parses into a list of plists." + (let* ((resp-lines (s-split "\n" (s-trim resp))) + (parsed (--map (dumb-jump-parse-response-line it cur-file) resp-lines))) + (dumb-jump-parse-response-lines parsed cur-file cur-line-num))) + +(defun dumb-jump-parse-rg-response (resp cur-file cur-line-num) + "Takes a rg response RESP and parses into a list of plists." + (let* ((resp-lines (s-split "\n" (s-trim resp))) + (parsed (--map (dumb-jump-parse-response-line it cur-file) resp-lines))) + (dumb-jump-parse-response-lines parsed cur-file cur-line-num))) + +(defun dumb-jump-parse-git-grep-response (resp cur-file cur-line-num) + "Takes a git grep response RESP and parses into a list of plists." + (let* ((resp-lines (s-split "\n" (s-trim resp))) + (parsed (--map (dumb-jump-parse-response-line it cur-file) resp-lines))) + (dumb-jump-parse-response-lines parsed cur-file cur-line-num))) + +(defun dumb-jump-re-match (re s) + "Does regular expression RE match string S. If RE is nil return nil." + (when (and re s) + (s-match re s))) + +(defun dumb-jump-get-ctx-type-by-language (lang pt-ctx) + "Detect the type of context by the language LANG and its context PT-CTX." + (let* ((contexts (--filter (string= (plist-get it ':language) lang) dumb-jump-language-contexts)) + (usable-ctxs + (when (> (length contexts) 0) + (--filter (and (or (null (plist-get it :left)) + (dumb-jump-re-match (plist-get it :left) + (plist-get pt-ctx :left))) + (or (null (plist-get it :right)) + (dumb-jump-re-match (plist-get it :right) + (plist-get pt-ctx :right)))) + contexts))) + (use-ctx (= (length (--filter + (string= (plist-get it ':type) + (and usable-ctxs (plist-get (car usable-ctxs) :type))) + usable-ctxs)) + (length usable-ctxs)))) + + (when (and usable-ctxs use-ctx) + (plist-get (car usable-ctxs) :type)))) + +(defun dumb-jump-get-ext-includes (language) + "Generate the --include grep argument of file extensions by LANGUAGE." + (let ((exts (dumb-jump-get-file-exts-by-language language))) + (dumb-jump-arg-joiner + "--include" + (--map (format "\\*.%s" it) exts)))) + +(defun dumb-jump-arg-joiner (prefix values) + "Helper to generate command arg with its PREFIX for each value in VALUES." + (let ((args (s-join (format " %s " prefix) values))) + (if (and args values) + (format " %s %s " prefix args) + ""))) + +(defun dumb-jump-get-contextual-regexes (lang ctx-type searcher) + "Get list of search regular expressions by LANG and CTX-TYPE (variable, function, etc)." + (let* ((raw-rules (dumb-jump-get-rules-by-language lang searcher)) + (ctx-type (unless dumb-jump-ignore-context ctx-type)) + (ctx-rules + (if ctx-type + (--filter (string= (plist-get it :type) ctx-type) raw-rules) + raw-rules)) + (rules (or ctx-rules raw-rules)) + (regexes (--map (plist-get it :regex) rules))) + regexes)) + +(defun dumb-jump-populate-regex (it look-for variant) + "Populate IT regex template with LOOK-FOR." + (let ((boundary (cond ((eq variant 'rg) dumb-jump-rg-word-boundary) + ((eq variant 'ag) dumb-jump-ag-word-boundary) + ((eq variant 'git-grep-plus-ag) dumb-jump-ag-word-boundary) + ((eq variant 'git-grep) dumb-jump-git-grep-word-boundary) + (t dumb-jump-grep-word-boundary)))) + (let ((text it)) + (setq text (s-replace "\\j" boundary text)) + (when (eq variant 'gnu-grep) + (setq text (s-replace "\\s" "[[:space:]]" text))) + (setq text (s-replace "JJJ" (regexp-quote look-for) text)) + (when (and (eq variant 'rg) (string-prefix-p "-" text)) + (setq text (concat "[-]" (substring text 1)))) + text))) + +(defun dumb-jump-populate-regexes (look-for regexes variant) + "Take list of REGEXES and populate the LOOK-FOR target and return that list." + (--map (dumb-jump-populate-regex it look-for variant) regexes)) + +(defun dumb-jump-generate-ag-command (look-for cur-file proj regexes lang exclude-paths) + "Generate the ag response based on the needle LOOK-FOR in the directory PROJ." + (let* ((filled-regexes (dumb-jump-populate-regexes look-for regexes 'ag)) + (agtypes (dumb-jump-get-ag-type-by-language lang)) + (lang-exts (dumb-jump-get-file-exts-by-language lang)) + (proj-dir (file-name-as-directory proj)) + ;; TODO: --search-zip always? in case the include is the in gz area like emacs lisp code. + (cmd (concat dumb-jump-ag-cmd + " --nocolor --nogroup" + (if (member lang dumb-jump--case-insensitive-languages) + " --ignore-case" + "") + (if (s-ends-with? ".gz" cur-file) + " --search-zip" + "") + (when (not (s-blank? dumb-jump-ag-search-args)) + (concat " " dumb-jump-ag-search-args)) + (if agtypes + (s-join "" (--map (format " --%s" it) agtypes)) + ;; there can only be one `-G` arg + (concat " -G '(" + (s-join "|" (--map (format "\\.%s" it) lang-exts)) + ")$'")))) + (exclude-args (dumb-jump-arg-joiner + "--ignore-dir" (--map (shell-quote-argument (s-replace proj-dir "" it)) exclude-paths))) + (regex-args (shell-quote-argument (s-join "|" filled-regexes)))) + (if (= (length regexes) 0) + "" + (dumb-jump-concat-command cmd exclude-args regex-args proj)))) + +(defun dumb-jump-get-git-grep-files-matching-symbol (symbol proj-root) + "Search for the literal SYMBOL in the PROJ-ROOT via git grep for a list of file matches." + (let* ((cmd (format "git grep --full-name -F -c %s %s" (shell-quote-argument symbol) proj-root)) + (result (s-trim (shell-command-to-string cmd))) + (matched-files (--map (first (s-split ":" it)) + (s-split "\n" result)))) + matched-files)) + +(defun dumb-jump-format-files-as-ag-arg (files proj-root) + "Take a list of FILES and their PROJ-ROOT and return a `ag -G` argument." + (format "'(%s)'" (s-join "|" (--map (file-relative-name + (expand-file-name it proj-root)) + files)))) + +(defun dumb-jump-get-git-grep-files-matching-symbol-as-ag-arg (symbol proj-root) + "Get the files matching the SYMBOL via `git grep` in the PROJ-ROOT and return them formatted for `ag -G`." + (dumb-jump-format-files-as-ag-arg + (dumb-jump-get-git-grep-files-matching-symbol symbol proj-root) + proj-root)) + +;; git-grep plus ag only recommended for huge repos like the linux kernel +(defun dumb-jump-generate-git-grep-plus-ag-command (look-for cur-file proj regexes lang exclude-paths) + "Generate the ag response based on the needle LOOK-FOR in the directory PROJ. +Using ag to search only the files found via git-grep literal symbol search." + (let* ((filled-regexes (dumb-jump-populate-regexes look-for regexes 'ag)) + (proj-dir (file-name-as-directory proj)) + (ag-files-arg (dumb-jump-get-git-grep-files-matching-symbol-as-ag-arg look-for proj-dir)) + (cmd (concat dumb-jump-ag-cmd + " --nocolor --nogroup" + (if (member lang dumb-jump--case-insensitive-languages) + " --ignore-case" + "") + (if (s-ends-with? ".gz" cur-file) + " --search-zip" + "") + " -G " ag-files-arg + " ")) + (exclude-args (dumb-jump-arg-joiner + "--ignore-dir" (--map (shell-quote-argument (s-replace proj-dir "" it)) exclude-paths))) + (regex-args (shell-quote-argument (s-join "|" filled-regexes)))) + (if (= (length regexes) 0) + "" + (dumb-jump-concat-command cmd exclude-args regex-args proj)))) + +(defun dumb-jump-generate-rg-command (look-for _cur-file proj regexes lang exclude-paths) + "Generate the rg response based on the needle LOOK-FOR in the directory PROJ." + (let* ((filled-regexes (dumb-jump-populate-regexes look-for regexes 'rg)) + (rgtypes (dumb-jump-get-rg-type-by-language lang)) + (proj-dir (file-name-as-directory proj)) + (cmd (concat dumb-jump-rg-cmd + " --color never --no-heading --line-number -U" + (if (member lang dumb-jump--case-insensitive-languages) + " --ignore-case" + "") + (when (not (s-blank? dumb-jump-rg-search-args)) + (concat " " dumb-jump-rg-search-args)) + (s-join "" (--map (format " --type %s" it) rgtypes)))) + (exclude-args (dumb-jump-arg-joiner + "-g" (--map (shell-quote-argument (concat "!" (s-replace proj-dir "" it))) exclude-paths))) + (regex-args (shell-quote-argument (s-join "|" filled-regexes)))) + (if (= (length regexes) 0) + "" + (dumb-jump-concat-command cmd exclude-args regex-args proj)))) + +(defun dumb-jump-generate-git-grep-command (look-for cur-file proj regexes lang exclude-paths) + "Generate the git grep response based on the needle LOOK-FOR in the directory PROJ." + (let* ((filled-regexes (dumb-jump-populate-regexes look-for regexes 'git-grep)) + (ggtypes (when (file-name-extension cur-file) (dumb-jump-get-git-grep-type-by-language lang))) + (cmd (concat dumb-jump-git-grep-cmd + " --color=never --line-number" + (if (member lang dumb-jump--case-insensitive-languages) + " --ignore-case" + "") + (when dumb-jump-git-grep-search-untracked + " --untracked") + (when (not (s-blank? dumb-jump-git-grep-search-args)) + (concat " " dumb-jump-git-grep-search-args)) + " -E")) + (fileexps (s-join " " (or (--map (shell-quote-argument (format "%s/*.%s" proj it)) ggtypes) '(":/")))) + (exclude-args (s-join " " + (--map (shell-quote-argument (concat ":(exclude)" it)) + exclude-paths))) + (regex-args (shell-quote-argument (s-join "|" filled-regexes)))) + (if (= (length regexes) 0) + "" + (dumb-jump-concat-command cmd regex-args "--" fileexps exclude-args)))) + +(defun dumb-jump-generate-grep-command (look-for cur-file proj regexes lang exclude-paths) + "Find LOOK-FOR's CUR-FILE in the PROJ with REGEXES for the LANG but not in EXCLUDE-PATHS." + (let* ((filled-regexes (--map (shell-quote-argument it) + (dumb-jump-populate-regexes look-for regexes 'grep))) + (cmd (concat (if (eq system-type 'windows-nt) "" (concat dumb-jump-grep-prefix " ")) + (if (s-ends-with? ".gz" cur-file) + dumb-jump-zgrep-cmd + dumb-jump-grep-cmd))) + (case-args (if (member lang dumb-jump--case-insensitive-languages) + " --ignore-case" + "")) + (exclude-args (dumb-jump-arg-joiner "--exclude-dir" exclude-paths)) + (include-args (dumb-jump-get-ext-includes lang)) + (regex-args (dumb-jump-arg-joiner "-e" filled-regexes))) + (if (= (length regexes) 0) + "" + (dumb-jump-concat-command cmd dumb-jump-grep-args case-args exclude-args include-args regex-args proj)))) + +(defun dumb-jump-generate-gnu-grep-command (look-for cur-file proj regexes lang _exclude-paths) + "Find LOOK-FOR's CUR-FILE in the PROJ with REGEXES for the LANG but not in EXCLUDE-PATHS." + (let* ((filled-regexes (--map (shell-quote-argument it) + (dumb-jump-populate-regexes look-for regexes 'gnu-grep))) + (cmd (concat (if (eq system-type 'windows-nt) "" (concat dumb-jump-grep-prefix " ")) + (if (s-ends-with? ".gz" cur-file) + dumb-jump-zgrep-cmd + dumb-jump-grep-cmd))) + (case-args (if (member lang dumb-jump--case-insensitive-languages) + " --ignore-case" + "")) + ;; TODO: GNU grep doesn't support these, so skip them + (exclude-args "") + (include-args "") + (regex-args (dumb-jump-arg-joiner "-e" filled-regexes))) + (if (= (length regexes) 0) + "" + (dumb-jump-concat-command cmd dumb-jump-gnu-grep-args case-args exclude-args include-args regex-args proj)))) + +(defun dumb-jump-concat-command (&rest parts) + "Concat the PARTS of a command if each part has a length." + (s-join " " (-map #'s-trim (--filter (> (length it) 0) parts)))) + +(defun dumb-jump-get-file-exts-by-language (language) + "Return list of file extensions for a LANGUAGE." + (--map (plist-get it :ext) + (--filter (string= (plist-get it :language) language) + dumb-jump-language-file-exts))) + +(defun dumb-jump-get-ag-type-by-language (language) + "Return list of ag type argument for a LANGUAGE." + (-distinct (--map (plist-get it :agtype) + (--filter (and + (plist-get it :agtype) + (string= (plist-get it :language) language)) + dumb-jump-language-file-exts)))) + +(defun dumb-jump-get-rg-type-by-language (language) + "Return list of rg type argument for a LANGUAGE." + (-distinct (--map (plist-get it :rgtype) + (--filter (and + (plist-get it :rgtype) + (string= (plist-get it :language) language)) + dumb-jump-language-file-exts)))) + +(defun dumb-jump-get-git-grep-type-by-language (language) + "Return list of git grep type argument for a LANGUAGE." + (-distinct (--map (plist-get it :ext) + (--filter (and + (plist-get it :ext) + (string= (plist-get it :language) language)) + dumb-jump-language-file-exts)))) + +(defun dumb-jump-get-rules-by-language (language searcher) + "Return a list of rules for the LANGUAGE by SEARCHER." + (let* ((searcher-str (cond ((eq 'git-grep searcher) "git-grep") + ((eq 'rg searcher) "rg") + ((eq 'ag searcher) "ag") + ((eq 'git-grep-plus-ag searcher) "ag") + (t "grep"))) + (results (--filter (and + (string= (plist-get it ':language) language) + (member searcher-str (plist-get it ':supports))) + dumb-jump-find-rules))) + (if dumb-jump-functions-only + (--filter (string= (plist-get it ':type) "function") results) + results))) + +;;;###autoload +(define-minor-mode dumb-jump-mode + "Minor mode for jumping to variable and function definitions" + :global t + :keymap dumb-jump-mode-map) + + +;;; Xref Backend +(when (featurep 'xref) + (unless dumb-jump-disable-obsolete-warnings + (dolist (obsolete + '(dumb-jump-mode + dumb-jump-go + dumb-jump-go-prefer-external-other-window + dumb-jump-go-prompt + dumb-jump-quick-look + dumb-jump-go-other-window + dumb-jump-go-current-window + dumb-jump-go-prefer-external + dumb-jump-go-current-window)) + (make-obsolete + obsolete + (format "`%s' has been obsoleted by the xref interface." + obsolete) + "2020-06-26")) + (make-obsolete 'dumb-jump-back + "`dumb-jump-back' has been obsoleted by `xref-pop-marker-stack'." + "2020-06-26")) + + (cl-defmethod xref-backend-identifier-at-point ((_backend (eql dumb-jump))) + (let ((bounds (bounds-of-thing-at-point 'symbol))) + (and bounds (let* ((ident (dumb-jump-get-point-symbol)) + (start (car bounds)) + (col (- start (point-at-bol))) + (line (dumb-jump-get-point-line)) + (ctx (dumb-jump-get-point-context line ident col))) + (propertize ident :dumb-jump-ctx ctx))))) + + (cl-defmethod xref-backend-definitions ((_backend (eql dumb-jump)) prompt) + (let* ((info (dumb-jump-get-results prompt)) + (results (plist-get info :results)) + (look-for (or prompt (plist-get info :symbol))) + (proj-root (plist-get info :root)) + (issue (plist-get info :issue)) + (lang (plist-get info :lang)) + (processed (dumb-jump-process-results + results + (plist-get info :file) + proj-root + (plist-get info :ctx-type) + look-for + nil + nil + lang)) + (results (plist-get processed :results)) + (do-var-jump (plist-get processed :do-var-jump)) + (var-to-jump (plist-get processed :var-to-jump)) + (match-cur-file-front (plist-get processed :match-cur-file-front))) + + (dumb-jump-debug-message + look-for + (plist-get info :ctx-type) + var-to-jump + (pp-to-string match-cur-file-front) + (pp-to-string results) + match-cur-file-front + proj-root + (plist-get info :file)) + (cond ((eq issue 'nogrep) + (dumb-jump-message "Please install ag, rg, git grep or grep!")) + ((eq issue 'nosymbol) + (dumb-jump-message "No symbol under point.")) + ((s-ends-with? " file" lang) + (dumb-jump-message "Could not find rules for '%s'." lang)) + ((= (length results) 0) + (dumb-jump-message "'%s' %s %s declaration not found." look-for (if (s-blank? lang) "with unknown language so" lang) (plist-get info :ctx-type))) + (t (mapcar (lambda (res) + (xref-make + (plist-get res :context) + (xref-make-file-location + (expand-file-name (plist-get res :path)) + (plist-get res :line) + 0))) + (if do-var-jump + (list var-to-jump) + match-cur-file-front)))))) + + (cl-defmethod xref-backend-apropos ((_backend (eql dumb-jump)) pattern) + (xref-backend-definitions 'dumb-jump pattern)) + + (cl-defmethod xref-backend-identifier-completion-table ((_backend (eql dumb-jump))) + nil)) + +;;;###autoload +(defun dumb-jump-xref-activate () + "Function to activate xref backend. +Add this function to `xref-backend-functions' to dumb jump to be +activiated, whenever it finds a project. It is recommended to add +it to the end, so that it only gets activated when no better +option is found." + (and (dumb-jump-get-project-root default-directory) + 'dumb-jump)) + +(provide 'dumb-jump) +;;; dumb-jump.el ends here diff --git a/.emacs.d/lisp/ivy-faces.el b/.emacs.d/lisp/ivy-faces.el new file mode 100644 index 0000000..5f76ba9 --- /dev/null +++ b/.emacs.d/lisp/ivy-faces.el @@ -0,0 +1,145 @@ +;;; ivy-faces.el --- Faces for Ivy -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2025 Free Software Foundation, Inc. + +;; Author: Oleh Krehel +;; Keywords: convenience + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;;; Code: + +(defgroup ivy-faces nil + "Font-lock faces for `ivy'." + :group 'ivy + :group 'faces) + +(defface ivy-cursor + '((((class color) (background light)) + :background "black" :foreground "white") + (((class color) (background dark)) + :background "white" :foreground "black")) + "Cursor face for inline completion.") + +(defface ivy-current-match + '((((class color) (background light)) + :background "#1a4b77" :foreground "white" :extend t) + (((class color) (background dark)) + :background "#65a7e2" :foreground "black" :extend t)) + "Face used by Ivy for highlighting the current match.") + +(defface ivy-minibuffer-match-highlight + '((t :inherit highlight)) + "Face used by Ivy for highlighting the match under the cursor.") + +(defface ivy-minibuffer-match-face-1 + '((((class color) (background light)) + :background "#d3d3d3") + (((class color) (background dark)) + :background "#555555")) + "The background face for `ivy' minibuffer matches.") + +(defface ivy-minibuffer-match-face-2 + '((((class color) (background light)) + :background "#e99ce8" :weight bold) + (((class color) (background dark)) + :background "#777777" :weight bold)) + "Face for `ivy' minibuffer matches numbered 1 modulo 3.") + +(defface ivy-minibuffer-match-face-3 + '((((class color) (background light)) + :background "#bbbbff" :weight bold) + (((class color) (background dark)) + :background "#7777ff" :weight bold)) + "Face for `ivy' minibuffer matches numbered 2 modulo 3.") + +(defface ivy-minibuffer-match-face-4 + '((((class color) (background light)) + :background "#ffbbff" :weight bold) + (((class color) (background dark)) + :background "#8a498a" :weight bold)) + "Face for `ivy' minibuffer matches numbered 3 modulo 3.") + +(defface ivy-confirm-face + '((t :foreground "ForestGreen" :inherit minibuffer-prompt)) + "Face used by Ivy for a confirmation prompt.") + +(defface ivy-match-required-face + '((t :foreground "red" :inherit minibuffer-prompt)) + "Face used by Ivy for a match required prompt.") + +(defface ivy-subdir + '((t :inherit dired-directory)) + "Face used by Ivy for highlighting subdirs in the alternatives.") + +(defface ivy-org + '((t :inherit org-level-4)) + "Face used by Ivy for highlighting Org buffers in the alternatives.") + +(defface ivy-modified-buffer + '((t :inherit default)) + "Face used by Ivy for highlighting modified file visiting buffers.") + +(defface ivy-modified-outside-buffer + '((t :inherit default)) + "Face used by Ivy for highlighting file visiting buffers modified outside Emacs.") + +(defface ivy-remote + '((((class color) (background light)) + :foreground "#110099") + (((class color) (background dark)) + :foreground "#7B6BFF")) + "Face used by Ivy for highlighting remotes in the alternatives.") + +(defface ivy-virtual + '((t :inherit font-lock-builtin-face)) + "Face used by Ivy for matching virtual buffer names.") + +(defface ivy-action + '((t :inherit font-lock-builtin-face)) + "Face used by Ivy for displaying keys in `ivy-read-action'.") + +(defface ivy-highlight-face + '((t :inherit highlight)) + "Face used by Ivy to highlight certain candidates.") + +(defface ivy-prompt-match + '((t :inherit ivy-current-match)) + "Face used by Ivy for highlighting the selected prompt line.") + +(defface ivy-separator + '((t :inherit font-lock-doc-face)) + "Face for multiline source separator.") + +(defface ivy-grep-info + '((t :inherit compilation-info)) + "Face for highlighting grep information such as file names.") + +(defface ivy-grep-line-number + '((t :inherit compilation-line-number)) + "Face for displaying line numbers in grep messages.") + +(defface ivy-completions-annotations + '((t :inherit completions-annotations)) + "Face for displaying completion annotations.") + +(defface ivy-yanked-word + '((t :inherit highlight)) + "Face used to highlight yanked word.") + +(provide 'ivy-faces) + +;;; ivy-faces.el ends here diff --git a/.emacs.d/lisp/ivy-overlay.el b/.emacs.d/lisp/ivy-overlay.el new file mode 100644 index 0000000..8803e60 --- /dev/null +++ b/.emacs.d/lisp/ivy-overlay.el @@ -0,0 +1,176 @@ +;;; ivy-overlay.el --- Overlay display functions for Ivy -*- lexical-binding: t -*- + +;; Copyright (C) 2016-2025 Free Software Foundation, Inc. + +;; Author: Oleh Krehel +;; Keywords: convenience + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Normally, Ivy displays completion candidates and entered text in +;; the minibuffer. This file enables in-buffer completion to be +;; displayed at point instead. + +;;; Code: + +(eval-when-compile + (require 'cl-lib) + (require 'subr-x)) + +(defvar ivy--old-cursor-type t) + +(defvar ivy-overlay-at nil + "Overlay variable for `ivy-display-function-overlay'.") + +(declare-function ivy--truncate-string "ivy") + +(defun ivy-left-pad (str width) + "Return STR, but with each line indented by WIDTH spaces. +Lines are truncated to the window width." + (let ((padding (make-string width ?\s))) + (mapconcat (lambda (x) + (ivy--truncate-string (concat padding x) + (1- (+ (window-width) + (window-hscroll))))) + (split-string str "\n") + "\n"))) + +(defun ivy-overlay-cleanup () + "Clean up after `ivy-display-function-overlay'." + (when (overlayp ivy-overlay-at) + (delete-overlay ivy-overlay-at) + (setq ivy-overlay-at nil)) + (unless cursor-type + (setq cursor-type ivy--old-cursor-type)) + (when (fboundp 'company-abort) + (company-abort))) + +(defvar ivy-height) + +(defun ivy-overlay-show-after (str) + "Display STR in an overlay at point. + +First, fill each line of STR with spaces to the current column. +Then attach the overlay to the character before point." + (if ivy-overlay-at + (progn + (move-overlay ivy-overlay-at (1- (point)) (line-end-position)) + (overlay-put ivy-overlay-at 'invisible nil)) + (let ((available-height (- (window-height) (count-lines (window-start) (point)) 1))) + (unless (>= available-height ivy-height) + (recenter (- (window-height) ivy-height 2)))) + (setq ivy-overlay-at (make-overlay (1- (point)) (line-end-position))) + ;; Specify face to avoid clashing with other overlays. + (overlay-put ivy-overlay-at 'face 'default) + (overlay-put ivy-overlay-at 'priority 9999)) + (overlay-put ivy-overlay-at 'display str) + (overlay-put ivy-overlay-at 'after-string "")) + +(declare-function org-current-level "org") +(declare-function org-at-heading-p "org") +(defvar org-indent-indentation-per-level) +(defvar ivy-last) +(defvar ivy-text) +(defvar ivy-completion-beg) +(declare-function ivy--get-window "ivy") +(declare-function ivy-state-window "ivy" t t) + +(defun ivy-overlay--current-column () + "Return `current-column', ignoring `ivy-overlay-at'. +Temporarily make `ivy-overlay-at' invisible so that the +`string-width' of its `display' property is not included in the +`current-column' calculation by Emacs >= 29. +See URL `https://bugs.gnu.org/53795'." + (if (overlayp ivy-overlay-at) + (cl-letf (((overlay-get ivy-overlay-at 'invisible) t)) + (1+ (current-column))) + (current-column))) + +(defun ivy-overlay-impossible-p (_str) + (or + (and (eq major-mode 'org-mode) + ;; If this breaks, an alternative is to call the canonical function + ;; `org-in-src-block-p', which is slower. Neither approach works + ;; in Org versions that shipped with Emacs < 26, however. + (get-text-property (point) 'src-block)) + (<= (window-height) (+ ivy-height 2)) + (bobp) + (< (- (+ (window-width) (window-hscroll)) + (ivy-overlay--current-column)) + 30))) + +(defun ivy-overlay--org-indent () + "Return `ivy-overlay-at' indentation due to `org-indent-mode'. +That is, the additional number of columns needed under the mode." + ;; Emacs 28 includes the following fix for `https://bugs.gnu.org/49695': + ;; + ;; "Fix display of line/wrap-prefix when there's a display property at BOL" + ;; 662f91a795 2021-07-22 21:23:48 +0300 + ;; `https://git.sv.gnu.org/cgit/emacs.git/commit/?id=662f91a795' + ;; + ;; This increasingly misindents `ivy-overlay-at' with each additional Org + ;; level. See also `https://github.com/abo-abo/swiper/commit/ee7f7f8c79'. + ;; FIXME: Is there a better way to work around this? + (if (and (eq major-mode 'org-mode) + (bound-and-true-p org-indent-mode) + (< emacs-major-version 28)) + (let ((level (org-current-level))) + (if (org-at-heading-p) + (1- level) + (* org-indent-indentation-per-level (or level 1)))) + 0)) + +(defun ivy-display-function-overlay (str) + "Called from the minibuffer, display STR in an overlay in Ivy window. +Hide the minibuffer contents and cursor." + (if (save-selected-window + (select-window (ivy-state-window ivy-last)) + (ivy-overlay-impossible-p str)) + (let ((buffer-undo-list t)) + (save-excursion + (forward-line 1) + (insert str))) + (add-face-text-property (minibuffer-prompt-end) (point-max) + '(:foreground "white")) + (setq cursor-type nil) + (with-selected-window (ivy--get-window ivy-last) + (when cursor-type + (setq ivy--old-cursor-type cursor-type)) + (setq cursor-type nil) + (let ((overlay-str + (apply + #'concat + (buffer-substring (max (point-min) (1- (point))) (point)) + ivy-text + (and (eolp) " ") + (buffer-substring (point) (line-end-position)) + (and (> (length str) 0) + (list "\n" + (ivy-left-pad + (string-remove-prefix "\n" str) + (+ (ivy-overlay--org-indent) + (save-excursion + (when ivy-completion-beg + (goto-char ivy-completion-beg)) + (ivy-overlay--current-column))))))))) + (let ((cursor-offset (1+ (length ivy-text)))) + (add-face-text-property cursor-offset (1+ cursor-offset) + 'ivy-cursor t overlay-str)) + (ivy-overlay-show-after overlay-str))))) + +(provide 'ivy-overlay) + +;;; ivy-overlay.el ends here diff --git a/.emacs.d/lisp/ivy.el b/.emacs.d/lisp/ivy.el new file mode 100644 index 0000000..3c900c9 --- /dev/null +++ b/.emacs.d/lisp/ivy.el @@ -0,0 +1,5558 @@ +;;; ivy.el --- Incremental Vertical completYon -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2025 Free Software Foundation, Inc. + +;; Author: Oleh Krehel +;; Maintainer: Basil L. Contovounesios +;; URL: https://github.com/abo-abo/swiper +;; Version: 0.15.1 +;; Package-Requires: ((emacs "24.5")) +;; Keywords: matching + +;; This file is part of GNU Emacs. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; For a full copy of the GNU General Public License +;; see . + +;;; Commentary: + +;; This package provides `ivy-read' as an alternative to +;; `completing-read' and similar functions. +;; +;; There's no intricate code to determine the best candidate. +;; Instead, the user can navigate to it with `ivy-next-line' and +;; `ivy-previous-line'. +;; +;; The matching is done by splitting the input text by spaces and +;; re-building it into a regex. +;; So "for example" is transformed into "\\(for\\).*\\(example\\)". + +;;; Code: + +(require 'colir) +(require 'ivy-faces) +(autoload 'ivy-overlay-cleanup "ivy-overlay") +(autoload 'ivy-display-function-overlay "ivy-overlay") + +(require 'cl-lib) + +(eval-when-compile + (require 'subr-x) + + (unless (fboundp 'static-if) + (defmacro static-if (condition then-form &rest else-forms) + "Expand to THEN-FORM or ELSE-FORMS based on compile-time CONDITION. +Polyfill for Emacs 30 `static-if'." + (declare (debug (sexp sexp &rest sexp)) (indent 2)) + (if (eval condition lexical-binding) + then-form + (macroexp-progn else-forms))))) + +;;; Customization + +(defgroup ivy nil + "Incremental vertical completion." + :group 'convenience) + +(defcustom ivy-height 10 + "Number of lines for the minibuffer window. + +See also `ivy-height-alist'." + :type 'integer) + +(defcustom ivy-count-format "%-4d " + "The style to use for displaying the current candidate count for `ivy-read'. +Set this to \"\" to suppress the count visibility. +Set this to \"(%d/%d) \" to display both the index and the count." + :type '(choice + (const :tag "Count disabled" "") + (const :tag "Count matches" "%-4d ") + (const :tag "Count matches and show current match" "(%d/%d) ") + string)) + +(defcustom ivy-pre-prompt-function nil + "When non-nil, add strings before the `ivy-read' prompt." + :type '(choice + (const :tag "Do nothing" nil) + (function :tag "Custom function"))) + +(defcustom ivy-add-newline-after-prompt nil + "When non-nil, add a newline after the `ivy-read' prompt." + :type 'boolean) + +(defcustom ivy-wrap nil + "When non-nil, wrap around after the first and the last candidate." + :type 'boolean) + +(defcustom ivy-display-style 'fancy + "The style for formatting the minibuffer. + +By default, the matched strings are copied as is. + +The fancy display style highlights matching parts of the regexp, +a behavior similar to `swiper'." + :type '(choice + (const :tag "Plain" nil) + (const :tag "Fancy" fancy))) + +(defcustom ivy-on-del-error-function #'abort-recursive-edit + "Function to call when deletion fails during completion. +The usual reason for `ivy-backward-delete-char' to fail is when +there is no text left to delete, i.e., when it is called at the +beginning of the minibuffer. +The default setting provides a quick exit from completion. +Another common option is `ignore', which does nothing." + :type '(choice + (const :tag "Exit completion" abort-recursive-edit) + (const :tag "Do nothing" ignore) + (function :tag "Custom function"))) + +(defcustom ivy-extra-directories '("../" "./") + "Add this to the front of the list when completing file names. +Only \"./\" and \"../\" apply here. They appear in reverse order." + :type '(repeat :tag "Dirs" + (choice + (const :tag "Parent Directory" "../") + (const :tag "Current Directory" "./")))) + +(defcustom ivy-use-virtual-buffers nil + "When non-nil, add recent files and/or bookmarks to `ivy-switch-buffer'. +The value `recentf' includes only recent files to the virtual +buffers list, whereas the value `bookmarks' does the same for +bookmarks. Any other non-nil value includes both." + :type '(choice + (const :tag "Don't use virtual buffers" nil) + (const :tag "Recent files" recentf) + (const :tag "Bookmarks" bookmarks) + (const :tag "All virtual buffers" t))) + +(defvar ivy--display-function nil + "The display-function is used in current.") + +(defvar ivy-display-functions-props + '((ivy-display-function-overlay :cleanup ivy-overlay-cleanup)) + "Map Ivy display functions to their property lists. +Examples of properties include associated `:cleanup' functions.") + +(defcustom ivy-display-functions-alist + '((ivy-completion-in-region . ivy-display-function-overlay) + (t . nil)) + "An alist for customizing where to display the candidates. + +Each key is a caller symbol. When the value is nil (the default), +the candidates are shown in the minibuffer. Otherwise, the value +is a function which takes a string argument comprising the +current matching candidates and displays it somewhere. + +See also `https://github.com/abo-abo/swiper/wiki/ivy-display-function'." + :type '(alist + :key-type symbol + :value-type (choice + (const :tag "Minibuffer" nil) + (const :tag "LV" ivy-display-function-lv) + (const :tag "Popup" ivy-display-function-popup) + (const :tag "Overlay" ivy-display-function-overlay) + (function :tag "Custom function")))) + +(defvar ivy-completing-read-dynamic-collection nil + "Run `ivy-completing-read' with `:dynamic-collection t`.") + +(defcustom ivy-completing-read-handlers-alist + '((tmm-menubar . completing-read-default) + (tmm-shortcut . completing-read-default) + (bbdb-create . ivy-completing-read-with-empty-string-def) + (auto-insert . ivy-completing-read-with-empty-string-def) + (Info-on-current-buffer . ivy-completing-read-with-empty-string-def) + (Info-follow-reference . ivy-completing-read-with-empty-string-def) + (Info-menu . ivy-completing-read-with-empty-string-def) + (Info-index . ivy-completing-read-with-empty-string-def) + (Info-virtual-index . ivy-completing-read-with-empty-string-def) + (info-display-manual . ivy-completing-read-with-empty-string-def)) + "An alist of handlers to replace `completing-read' in `ivy-mode'." + :type '(alist :key-type symbol :value-type function)) + +(defcustom ivy-height-alist nil + "An alist to customize `ivy-height'. + +It is a list of (CALLER . HEIGHT). CALLER is a caller of +`ivy-read' and HEIGHT is the number of lines displayed. +HEIGHT can also be a function that returns the number of lines." + :type '(alist + :key-type function + :value-type (choice integer function))) + +(defvar ivy-completing-read-ignore-handlers-depth -1 + "Used to avoid infinite recursion. + +If `(minibuffer-depth)' equals this, `ivy-completing-read' will +act as if `ivy-completing-read-handlers-alist' is empty.") + +(defvar ivy-highlight-grep-commands nil + "List of grep-like commands.") + +(defvar ivy--actions-list nil + "A list of extra actions per command.") + +(defun ivy-set-actions (cmd actions) + "Set CMD extra exit points to ACTIONS." + (setq ivy--actions-list + (plist-put ivy--actions-list cmd actions))) + +(defun ivy-add-actions (cmd actions) + "Add extra exit points ACTIONS to CMD. +Existing exit points of CMD are overwritten by those in +ACTIONS that have the same key." + (setq ivy--actions-list + (plist-put ivy--actions-list cmd + (cl-delete-duplicates + (append (plist-get ivy--actions-list cmd) actions) + :key #'car :test #'equal)))) + +(defun ivy--compute-extra-actions (action caller) + "Add extra actions to ACTION based on CALLER." + (let* ((extra-actions (cl-delete-duplicates + (append (plist-get ivy--actions-list t) + (plist-get ivy--actions-list this-command) + (plist-get ivy--actions-list caller)) + :key #'car :test #'equal)) + (override-default (assoc "o" extra-actions))) + (cond (override-default + (cons 1 (cons override-default + (cl-delete "o" extra-actions + :key #'car :test #'equal)))) + ((not extra-actions) + action) + ((functionp action) + `(1 + ("o" ,action "default") + ,@extra-actions)) + ((null action) + `(1 + ("o" identity "default") + ,@extra-actions)) + (t + (cons (car action) + (cl-delete-duplicates (cdr (append action extra-actions)) + :key #'car :test #'equal :from-end t)))))) + +(defvar ivy--prompts-list nil) + +(defun ivy-set-prompt (caller prompt-fn) + "Associate CALLER with PROMPT-FN. +PROMPT-FN is a function of no arguments that returns a prompt string." + (setq ivy--prompts-list + (plist-put ivy--prompts-list caller prompt-fn))) + +(defvar ivy--display-transformers-alist nil + "A list of str->str transformers per command.") + +(defun ivy-set-display-transformer (cmd transformer) + "Set CMD a displayed candidate TRANSFORMER. + +It's a lambda that takes a string one of the candidates in the +collection and returns a string for display, the same candidate +plus some extra information. + +This lambda is called only on the `ivy-height' candidates that +are about to be displayed, not on the whole collection." + (declare (obsolete "use `ivy-configure' :display-transformer-fn instead." + "0.13.2 (2020-05-20)")) + (ivy--alist-set 'ivy--display-transformers-alist cmd transformer)) + +(defvar ivy--sources-list nil + "A list of extra sources per command.") + +(defun ivy-set-sources (cmd sources) + "Attach to CMD a list of extra SOURCES. + +Each static source is a function that takes no argument and +returns a list of strings. + +The (original-source) determines the position of the original +dynamic source. + +Extra dynamic sources aren't supported yet. + +Example: + + (defun small-recentf () + (cl-subseq recentf-list 0 20)) + + (ivy-set-sources + \\='counsel-locate + \\='((small-recentf) + (original-source)))" + (setq ivy--sources-list + (plist-put ivy--sources-list cmd sources))) + +(defun ivy--compute-extra-candidates (caller) + (let ((extra-sources (or (plist-get ivy--sources-list caller) + '((original-source)))) + (result nil)) + (dolist (source extra-sources) + (cond ((equal source '(original-source)) + (push source result)) + ((null (cdr source)) + (push (list (car source) (funcall (car source))) result)))) + result)) + +(defvar ivy-current-prefix-arg nil + "Prefix arg to pass to actions. +This is a global variable that is set by ivy functions for use in +action functions.") + +;;; Keymap + +(autoload 'minibuffer-keyboard-quit "delsel" nil t) +(autoload 'hydra-ivy/body "ivy-hydra" nil t) +(autoload 'ivy-hydra-read-action "ivy-hydra" nil t) + +(defun ivy-define-key (keymap key def) + "Forward to (`define-key' KEYMAP KEY DEF). +Remove DEF from `counsel-M-x' list." + (function-put def 'no-counsel-M-x t) + (define-key keymap key def)) + +(defvar ivy-minibuffer-map + (let ((map (make-sparse-keymap))) + (ivy-define-key map (kbd "C-m") #'ivy-done) + (define-key map [down-mouse-1] #'ignore) + (ivy-define-key map [mouse-1] #'ivy-mouse-done) + (ivy-define-key map [mouse-3] #'ivy-mouse-dispatching-done) + (ivy-define-key map (kbd "C-M-m") #'ivy-call) + (ivy-define-key map (kbd "C-j") #'ivy-alt-done) + (ivy-define-key map (kbd "C-M-j") #'ivy-immediate-done) + (ivy-define-key map (kbd "TAB") #'ivy-partial-or-done) + (ivy-define-key map `[remap ,#'next-line] #'ivy-next-line) + (ivy-define-key map `[remap ,#'previous-line] #'ivy-previous-line) + (ivy-define-key map (kbd "C-r") #'ivy-reverse-i-search) + (define-key map (kbd "SPC") #'self-insert-command) + (ivy-define-key map `[remap ,#'delete-backward-char] + #'ivy-backward-delete-char) + (ivy-define-key map `[remap ,#'backward-delete-char-untabify] + #'ivy-backward-delete-char) + (ivy-define-key map `[remap ,#'backward-kill-word] #'ivy-backward-kill-word) + (ivy-define-key map `[remap ,#'delete-char] #'ivy-delete-char) + (ivy-define-key map `[remap ,#'forward-char] #'ivy-forward-char) + (ivy-define-key map (kbd "") #'ivy-forward-char) + (ivy-define-key map `[remap ,#'kill-word] #'ivy-kill-word) + (ivy-define-key map `[remap ,#'beginning-of-buffer] + #'ivy-beginning-of-buffer) + (ivy-define-key map `[remap ,#'end-of-buffer] #'ivy-end-of-buffer) + (ivy-define-key map (kbd "M-n") #'ivy-next-history-element) + (ivy-define-key map (kbd "M-p") #'ivy-previous-history-element) + (define-key map (kbd "C-g") #'minibuffer-keyboard-quit) + (ivy-define-key map `[remap ,#'scroll-up-command] #'ivy-scroll-up-command) + (ivy-define-key map `[remap ,#'scroll-down-command] + #'ivy-scroll-down-command) + (ivy-define-key map (kbd "") #'ivy-scroll-up-command) + (ivy-define-key map (kbd "") #'ivy-scroll-down-command) + (ivy-define-key map (kbd "C-v") #'ivy-scroll-up-command) + (ivy-define-key map (kbd "M-v") #'ivy-scroll-down-command) + (ivy-define-key map (kbd "C-M-n") #'ivy-next-line-and-call) + (ivy-define-key map (kbd "C-M-p") #'ivy-previous-line-and-call) + (ivy-define-key map (kbd "M-a") #'ivy-toggle-marks) + (ivy-define-key map (kbd "M-r") #'ivy-toggle-regexp-quote) + (ivy-define-key map (kbd "M-j") #'ivy-yank-word) + (ivy-define-key map (kbd "M-i") #'ivy-insert-current) + (ivy-define-key map (kbd "C-M-y") #'ivy-insert-current-full) + (ivy-define-key map (kbd "C-o") #'hydra-ivy/body) + (ivy-define-key map (kbd "M-o") #'ivy-dispatching-done) + (ivy-define-key map (kbd "C-M-o") #'ivy-dispatching-call) + (ivy-define-key map `[remap ,#'kill-line] #'ivy-kill-line) + (ivy-define-key map `[remap ,#'kill-whole-line] #'ivy-kill-whole-line) + (ivy-define-key map (kbd "S-SPC") #'ivy-restrict-to-matches) + (ivy-define-key map `[remap ,#'kill-ring-save] #'ivy-kill-ring-save) + (ivy-define-key map (kbd "C-M-a") #'ivy-read-action) + (ivy-define-key map (kbd "C-c C-o") #'ivy-occur) + (ivy-define-key map (kbd "C-c C-a") #'ivy-toggle-ignore) + (ivy-define-key map (kbd "C-c C-s") #'ivy-rotate-sort) + (ivy-define-key map `[remap ,#'describe-mode] #'ivy-help) + (ivy-define-key map "$" #'ivy-magic-read-file-env) + map) + "Keymap used in the minibuffer.") + +(defvar ivy-mode-map + (let ((map (make-sparse-keymap))) + (ivy-define-key map `[remap ,#'switch-to-buffer] #'ivy-switch-buffer) + (ivy-define-key map `[remap ,#'switch-to-buffer-other-window] + #'ivy-switch-buffer-other-window) + map) + "Keymap for `ivy-mode'.") + +;;; Globals + +(cl-defstruct ivy-state + prompt collection + predicate require-match initial-input + history preselect keymap update-fn sort + ;; The frame in which `ivy-read' was called + frame + ;; The window in which `ivy-read' was called + window + ;; The buffer in which `ivy-read' was called + buffer + ;; The value of `ivy-text' to be used by `ivy-occur' + text + action + unwind + re-builder + matcher + ;; When this is non-nil, call it for each input change to get new candidates + dynamic-collection + ;; A lambda that transforms candidates only for display + display-transformer-fn + directory + caller + current + def + ignore + multi-action + extra-props) + +(defvar ivy-last (make-ivy-state) + "The last parameters passed to `ivy-read'. + +This should eventually become a stack so that you could use +`ivy-read' recursively.") + +(defvar ivy--sessions nil + "Alist mapping session symbols to `ivy-state' objects.") + +(defvar ivy-recursive-last nil) + +(defvar ivy-recursive-restore t + "When non-nil, restore the above state when exiting the minibuffer. +This variable is let-bound to nil by functions that take care of +the restoring themselves.") + +(defsubst ivy-set-action (action) + "Set the current `ivy-last' field to ACTION." + (setf (ivy-state-action ivy-last) action)) + +(defvar inhibit-message) + +(defvar ffap-machine-p-known) + +(defun ivy-thing-at-point () + "Return a string that corresponds to the current thing at point." + (substring-no-properties + (cond + ((use-region-p) + (let* ((beg (region-beginning)) + (end (region-end)) + (eol (save-excursion (goto-char beg) (line-end-position)))) + (buffer-substring-no-properties beg (min end eol)))) + ((let ((url (thing-at-point 'url))) + ;; Work around `https://bugs.gnu.org/58091'. + (and (stringp url) url))) + ((and (eq (ivy-state-collection ivy-last) #'read-file-name-internal) + (let ((inhibit-message t) + (ffap-machine-p-known 'reject)) + (run-hook-with-args-until-success 'file-name-at-point-functions)))) + ((let ((s (thing-at-point 'symbol))) + (and (stringp s) + (if (string-match "\\`[`']?\\(.*?\\)'?\\'" s) + (match-string 1 s) + s)))) + ((looking-at "(+\\(\\(?:\\sw\\|\\s_\\)+\\)\\_>") + (match-string-no-properties 1)) + (t + "")))) + +(defvar ivy-history nil + "History list of candidates entered in the minibuffer. + +Maximum length of the history list is determined by the value +of `history-length'.") + +(defvar ivy--directory nil + "Current directory when completing file names.") + +(defvar ivy--directory-hist nil + "Store the history of directories. +This allows RET to reverse consecutive DEL.") + +(defvar ivy--length 0 + "Store the amount of viable candidates.") + +(defvar ivy-text "" + "Store the user's string as it is typed in.") + +(defvar ivy-regex "" + "Store the regex value that corresponds to `ivy-text'.") + +(defvar ivy--regex-function #'ivy--regex + "Current function for building a regex.") + +(defun ivy-set-text (str) + "Set `ivy-text' to STR." + (setq ivy-text str) + (setq ivy-regex (funcall ivy--regex-function ivy-text))) + +(defvar ivy--index 0 + "Store the index of the current candidate.") + +(defvar ivy--window-index 0 + "Store the index of the current candidate in the minibuffer window. + +This means it's between 0 and `ivy-height'.") + +(defvar ivy-exit nil + "Store `done' if the completion was successfully selected. +Otherwise, store nil.") + +(defvar ivy--all-candidates nil + "Store the candidates passed to `ivy-read'.") + +(defvar ivy--extra-candidates '((original-source)) + "Store candidates added by the extra sources. + +This is an internal-use alist. Each key is a function name, or +original-source (which represents where the current dynamic +candidates should go). + +Each value is an evaluation of the function, in case of static +sources. These values will subsequently be filtered on `ivy-text'. + +This variable is set by `ivy-read' and used by `ivy--set-candidates'.") + +(defcustom ivy-use-ignore-default t + "The default policy for user-configured candidate filtering." + :type '(choice + (const :tag "Ignore ignored always" always) + (const :tag "Ignore ignored when others exist" t) + (const :tag "Don't ignore" nil))) + +(defvar ivy-use-ignore t + "Store policy for user-configured candidate filtering. +This may be changed dynamically by `ivy-toggle-ignore'. +Use `ivy-use-ignore-default' for a permanent configuration.") + +(defvar ivy--default nil + "Default initial input.") + +(defvar ivy--prompt nil + "Store the format-style prompt. +When non-nil, it should contain at least one %d.") + +(defvar ivy--prompt-extra "" + "Temporary modifications to the prompt.") + +(defvar ivy--old-re nil + "Store the old regexp. +Either a string or a list for `ivy-re-match'.") + +(defvar ivy--old-cands nil + "Store the candidates matched by `ivy--old-re'.") + +(defvar ivy--highlight-function 'ivy--highlight-default + "Current function for formatting the candidates.") + +(defvar ivy--subexps 0 + "Number of groups in the current `ivy--regex'.") + +(defvar ivy--full-length nil + "The total amount of candidates when :dynamic-collection is non-nil.") + +(defvar ivy--old-text "" + "Store old `ivy-text' for dynamic completion.") + +(defvar ivy--trying-to-resume-dynamic-collection nil + "Non-nil if resuming from a dynamic collection. +When non-nil, ivy will wait until the first chunk of asynchronous +candidates has been received before selecting the last +preselected candidate.") + +(defun ivy--set-index-dynamic-collection () + (when ivy--trying-to-resume-dynamic-collection + (let ((preselect-index + (ivy--preselect-index (ivy-state-preselect ivy-last) ivy--all-candidates))) + (when preselect-index + (ivy-set-index preselect-index))) + (setq ivy--trying-to-resume-dynamic-collection nil))) + +(defcustom ivy-case-fold-search-default + (if search-upper-case + 'auto + case-fold-search) + "The default value for `case-fold-search' in Ivy operations. +The special value `auto' means case folding is performed so long +as the entire input string comprises lower-case characters. This +corresponds to the default behaviour of most Emacs search +functionality, e.g. as seen in `isearch'." + :link '(info-link "(emacs)Lax Search") + :type '(choice + (const :tag "Auto" auto) + (const :tag "Always" t) + (const :tag "Never" nil))) + +(defvar ivy-case-fold-search ivy-case-fold-search-default + "Store the current overriding `case-fold-search'.") + +(defcustom ivy-more-chars-alist + '((t . 3)) + "Map commands to their minimum required input length. +That is the number of characters prompted for before fetching +candidates. The special key t is used as a fallback." + :type '(alist :key-type symbol :value-type integer)) + +(defun ivy-more-chars () + "Return two fake candidates prompting for at least N input. +N is obtained from `ivy-more-chars-alist'." + (let ((diff (- (ivy-alist-setting ivy-more-chars-alist) + (length ivy-text)))) + (when (> diff 0) + (list "" (format "%d chars more" diff))))) + +(defun ivy--case-fold-p (string) + "Return nil if STRING should be matched case-sensitively." + (if (eq ivy-case-fold-search 'auto) + (string= string (downcase string)) + ivy-case-fold-search)) + +(defun ivy--case-fold-string= (s1 s2) + "Like `string=', but obeys `case-fold-search'." + (eq t (compare-strings s1 nil nil s2 nil nil case-fold-search))) + +(defmacro ivy-quit-and-run (&rest body) + "Quit the minibuffer and run BODY afterwards." + (declare (indent 0)) + `(progn + (put 'quit 'error-message "") + (run-at-time nil nil + (lambda () + (put 'quit 'error-message "Quit") + (with-demoted-errors "Error: %S" + ,@body))) + (abort-recursive-edit))) + +(defun ivy-exit-with-action (action &optional exit-code) + "Quit the minibuffer and call ACTION afterwards." + (ivy-set-action + `(lambda (x) + (funcall ',action x) + (ivy-set-action ',(ivy-state-action ivy-last)))) + (setq ivy-exit (or exit-code 'done)) + (exit-minibuffer)) + +(defmacro with-ivy-window (&rest body) + "Execute BODY in the window from which `ivy-read' was called." + (declare (indent 0) + (debug t)) + `(with-selected-window (ivy--get-window ivy-last) + ,@body)) + +(defun ivy--expand-file-name (text) + (cond + ((eq (ivy-state-history ivy-last) 'grep-files-history) + text) + (ivy--directory + (if (and (string-match-p "^/" text) (file-remote-p ivy--directory)) + (let ((parts (split-string ivy--directory ":"))) + (concat (nth 0 parts) ":" (nth 1 parts) ":" text)) + (expand-file-name text ivy--directory))) + (t + text))) + +(defun ivy--done (text) + "Insert TEXT and exit minibuffer." + (if (member (ivy-state-prompt ivy-last) '("Create directory: " "Make directory: ")) + (ivy-immediate-done) + (when (stringp text) + (insert + (setf (ivy-state-current ivy-last) + (ivy--expand-file-name text)))) + (setq ivy-exit 'done) + (exit-minibuffer))) + +(defcustom ivy-use-selectable-prompt nil + "When non-nil, make the prompt line selectable like a candidate. + +The prompt line can be selected by calling `ivy-previous-line' when the first +regular candidate is selected. Both actions `ivy-done' and `ivy-alt-done', +when called on a selected prompt, are forwarded to `ivy-immediate-done', which +results to the same as calling `ivy-immediate-done' explicitly when a regular +candidate is selected. + +Note that if `ivy-wrap' is set to t, calling `ivy-previous-line' when the +prompt is selected wraps around to the last candidate, while calling +`ivy-next-line' on the last candidate wraps around to the first +candidate, not the prompt." + :type 'boolean) + +(defvar ivy--use-selectable-prompt nil + "Store the effective `ivy-use-selectable-prompt' for current session.") + +(defun ivy--prompt-selectable-p () + "Return t if the prompt line is selectable." + (and ivy-use-selectable-prompt + (or (memq (ivy-state-require-match ivy-last) + '(nil confirm confirm-after-completion)) + ;; :require-match is t, but "" is in the collection + (let ((coll (ivy-state-collection ivy-last))) + (and (listp coll) + (if (consp (car coll)) + (member '("") coll) + (member "" coll))))))) + +(defun ivy--prompt-selected-p () + "Return t if the prompt line is selected." + (and ivy--use-selectable-prompt + (= ivy--index -1))) + +;;; Commands + +(defun ivy-done () + "Exit the minibuffer with the selected candidate." + (interactive) + (if (ivy--prompt-selected-p) + (ivy-immediate-done) + (setq ivy-current-prefix-arg current-prefix-arg) + (let ((require-match (ivy-state-require-match ivy-last)) + (input (ivy--input))) + (delete-minibuffer-contents) + (cond ((and (= ivy--length 0) + (eq this-command 'ivy-dispatching-done)) + (ivy--done ivy-text)) + ((or (> ivy--length 0) + ;; the action from `ivy-dispatching-done' may not need a + ;; candidate at all + (eq this-command 'ivy-dispatching-done)) + (ivy--done (ivy-state-current ivy-last))) + ((string= " (confirm)" ivy--prompt-extra) + (ivy--done ivy-text)) + ((or (and (memq (ivy-state-collection ivy-last) + '(read-file-name-internal internal-complete-buffer)) + (eq confirm-nonexistent-file-or-buffer t)) + (and (functionp require-match) + (setq require-match (funcall require-match)))) + (setq ivy--prompt-extra " (confirm)") + (insert input) + (ivy--exhibit)) + ((memq require-match '(nil confirm confirm-after-completion)) + (ivy--done ivy-text)) + (t + (setq ivy--prompt-extra " (match required)") + (insert ivy-text) + (ivy--exhibit)))))) + +(defvar ivy-mouse-1-tooltip + "Exit the minibuffer with the selected candidate." + "The doc visible in the tooltip for mouse-1 binding in the minibuffer.") +(defvar ivy-mouse-3-tooltip + "Display alternative actions." + "The doc visible in the tooltip for mouse-3 binding in the minibuffer.") + +(make-obsolete-variable 'ivy-mouse-1-tooltip 'ivy-mouse-1-help + "0.15.0 (2024-01-14)") +(make-obsolete-variable 'ivy-mouse-3-tooltip 'ivy-mouse-3-help + "0.15.0 (2024-01-14)") + +(defvar ivy-mouse-1-help + (format (if (> emacs-major-version 28) "\\`%s': %s" "%s: %s") + "mouse-1" "Exit the minibuffer with the selected candidate") + "Tooltip doc for \\`mouse-1' binding in the minibuffer.") + +(defvar ivy-mouse-3-help + (format (if (> emacs-major-version 28) "\\`%s': %s" "%s: %s") + "mouse-3" "Display alternative actions") + "Tooltip doc for \\`mouse-3' binding in the minibuffer.") + +(defun ivy--help-echo (_win _obj _pos) + "Return a `help-echo' string for mouse bindings on minibuffer candidates." + (concat ivy-mouse-1-help (if tooltip-mode "\n" " ") ivy-mouse-3-help)) + +(defun ivy-mouse-offset (event) + "Compute the offset between the candidate at point and the selected one." + (if event + (let* ((line-number-at-point + (max 2 + (line-number-at-pos (posn-point (event-start event))))) + + (line-number-candidate ;; convert to 0 based index + (- line-number-at-point 2)) + (offset + (- line-number-candidate + ivy--window-index))) + offset) + nil)) + +(defun ivy-mouse-done (event) + (interactive "@e") + (let ((offset (ivy-mouse-offset event))) + (when offset + (ivy-next-line offset) + (ivy--exhibit) + (ivy-alt-done)))) + +(defun ivy-mouse-dispatching-done (event) + (interactive "@e") + (let ((offset (ivy-mouse-offset event))) + (when offset + (ivy-next-line offset) + (ivy--exhibit) + (ivy-dispatching-done)))) + +(defcustom ivy-read-action-format-function 'ivy-read-action-format-default + "Function used to transform the actions list into a docstring." + :type '(radio + (function-item ivy-read-action-format-default) + (function-item ivy-read-action-format-columns))) + +(defun ivy-read-action-format-default (actions) + "Create a docstring from ACTIONS. + +ACTIONS is a list. Each list item is a list of 3 items: +key (a string), cmd and doc (a string)." + (format "%s\n%s\n" + (if (eq this-command 'ivy-read-action) + "Select action: " + (ivy-state-current ivy-last)) + (mapconcat + (lambda (x) + (format "%s: %s" + (propertize + (car x) + 'face 'ivy-action) + (nth 2 x))) + actions + "\n"))) + +(defun ivy-read-action-format-columns (actions) + "Create a potentially multi-column docstring from ACTIONS. +Several columns are used as needed to preserve `ivy-height'. + +ACTIONS is a list with elements of the form (KEY COMMAND DOC), +where KEY and DOC are strings." + (let ((length (length actions)) + (i 0) + (max-rows (- ivy-height 1)) + rows cols col lwidth rwidth) + (while (< i length) + (setq col (cl-subseq actions i (min length (cl-incf i max-rows)))) + (setq lwidth (apply 'max (mapcar (lambda (x) + (length (nth 0 x))) + col))) + (setq rwidth (apply 'max (mapcar (lambda (x) + (length (nth 2 x))) + col))) + (setq col (mapcar (lambda (x) + (format (format "%%%ds: %%-%ds" lwidth rwidth) + (propertize (car x) 'face 'ivy-action) + (nth 2 x))) + col)) + (cond + ((null rows) + (setq rows (length col))) + ((< (length col) rows) + (setq col (append col (make-list (- rows (length col)) ""))))) + (push col cols)) + (format "%s\n%s\n" + (if (eq this-command 'ivy-read-action) + "Select action: " + (ivy-state-current ivy-last)) + (mapconcat 'identity + (apply 'cl-mapcar + (lambda (&rest args) + (mapconcat 'identity args " | ")) + (nreverse cols)) + "\n")))) + +(defcustom ivy-read-action-function #'ivy-read-action-by-key + "Function used to read an action." + :type '(radio + (function-item ivy-read-action-by-key) + (function-item ivy-read-action-ivy) + (function-item ivy-hydra-read-action))) + +(defun ivy-read-action () + "Change the action to one of the available ones. + +Return nil for `minibuffer-keyboard-quit' or wrong key during the +selection, non-nil otherwise." + (interactive) + (let ((actions (ivy-state-action ivy-last))) + (if (not (ivy--actionp actions)) + t + (let ((ivy--directory ivy--directory)) + (funcall ivy-read-action-function actions))))) + +(defvar set-message-function) + +(defun ivy-read-action-by-key (actions) + (let* ((set-message-function nil) + (hint (funcall ivy-read-action-format-function (cdr actions))) + (resize-mini-windows t) + (key "") + action-idx) + (while (and (setq action-idx (cl-position-if + (lambda (x) + (string-prefix-p key (car x))) + (cdr actions))) + (not (string= key (car (nth action-idx (cdr actions)))))) + (setq key (concat key (key-description (vector (read-key hint)))))) + ;; Ignore resize errors with minibuffer-only frames (#2726). + (ignore-errors (ivy-shrink-after-dispatching)) + (cond ((member key '("ESC" "C-g" "M-o")) + nil) + ((null action-idx) + (message "%s is not bound" key) + nil) + (t + (message "") + (setcar actions (1+ action-idx)) + (ivy-set-action actions))))) + +(defvar ivy-marked-candidates nil + "List of marked candidates. +Use `ivy-mark' to populate this. + +When this list is non-nil at the end of the session, the action +will be called for each element of this list.") + +(defun ivy-read-action-ivy (actions) + "Select an action from ACTIONS using Ivy." + (let ((enable-recursive-minibuffers t)) + (if (and (> (minibuffer-depth) 1) + (eq (ivy-state-caller ivy-last) 'ivy-read-action-ivy)) + (minibuffer-keyboard-quit) + (let ((ivy-marked-candidates ivy-marked-candidates)) + (ivy-read (format "action (%s): " (ivy-state-current ivy-last)) + (cl-mapcar + (lambda (a i) (cons (format "[%s] %s" (nth 0 a) (nth 2 a)) i)) + (cdr actions) (number-sequence 1 (length (cdr actions)))) + :action (lambda (a) + (setcar actions (cdr a)) + (ivy-set-action actions)) + :caller 'ivy-read-action-ivy))))) + +(defun ivy-shrink-after-dispatching () + "Shrink the window after dispatching when action list is too large." + (when (window-minibuffer-p) + (window-resize nil (- ivy-height (window-height))))) + +(defun ivy-dispatching-done () + "Select one of the available actions and call `ivy-done'." + (interactive) + (let ((ivy-exit 'ivy-dispatching-done)) + (when (ivy-read-action) + (ivy-done))) + (ivy-shrink-after-dispatching)) + +(defun ivy-dispatching-call () + "Select one of the available actions and call `ivy-call'." + (interactive) + (setq ivy-current-prefix-arg current-prefix-arg) + (let ((actions (copy-sequence (ivy-state-action ivy-last))) + (old-ivy-text ivy-text)) + (unwind-protect + (when (ivy-read-action) + (ivy-set-text old-ivy-text) + (ivy-call)) + (ivy-set-action actions))) + (ivy-shrink-after-dispatching)) + +(defun ivy-build-tramp-name (x) + "Reconstruct X into a path. +Is is a cons cell, related to `tramp-get-completion-function'." + (let ((user (car x)) + (domain (cadr x))) + (if user + (concat user "@" domain) + domain))) + +(declare-function Info-find-node "info") +(declare-function Info-read-node-name-1 "info") +(declare-function tramp-get-completion-function "tramp") + +(defcustom ivy-alt-done-functions-alist nil + "Customize what `ivy-alt-done' does per-collection." + :type '(alist :key-type symbol :value-type function)) + +(defun ivy--completing-fname-p () + (let ((meta (ignore-errors + (funcall (ivy-state-collection ivy-last) ivy-text nil 'metadata)))) + (and (consp meta) + (eq 'file (cdr (assoc 'category meta)))))) + +(defun ivy-alt-done (&optional arg) + "Exit the minibuffer with the selected candidate. +When ARG is t, exit with current text, ignoring the candidates. +When the current candidate during file name completion is a +directory, continue completion from within that directory instead +of exiting. This function is otherwise like `ivy-done'." + (interactive "P") + (setq ivy-current-prefix-arg current-prefix-arg) + (let (alt-done-fn) + (cond ((or arg (ivy--prompt-selected-p)) + (ivy-immediate-done)) + ((setq alt-done-fn (ivy-alist-setting ivy-alt-done-functions-alist)) + (funcall alt-done-fn)) + ((ivy--completing-fname-p) + (ivy--directory-done)) + (t + (ivy-done))))) + +(defun ivy--info-alt-done () + (if (member (ivy-state-current ivy-last) '("(./)" "(../)")) + (ivy-quit-and-run + (ivy-read "Go to file: " #'read-file-name-internal + :action (lambda (x) + (Info-find-node + (expand-file-name x ivy--directory) + "Top")))) + (ivy-done))) + +(defvar ivy-auto-select-single-candidate nil + "When non-nil, auto-select the candidate if it is the only one. +When t, it is the same as if the user were prompted and selected the candidate +by calling the default action. This variable has no use unless the collection +contains a single candidate.") + +(defun ivy--directory-enter () + (let (dir) + (when (and + (> ivy--length 0) + (not (string= (ivy-state-current ivy-last) "./")) + (setq dir (ivy-expand-file-if-directory (ivy-state-current ivy-last)))) + (ivy--cd dir) + (ivy--exhibit)))) + +(defun ivy--handle-directory (input) + "Detect the next directory based on special values of INPUT." + (cond ((string= input "/") + "/") + ((string= input "/sudo::") + (concat input ivy--directory)))) + +(defun ivy--tramp-candidates () + (let ((method (match-string 1 ivy-text)) + (user (match-string 2 ivy-text)) + (rest (match-string 3 ivy-text)) + res) + (dolist (x (tramp-get-completion-function method)) + (setq res (append res (funcall (car x) (cadr x))))) + (setq res (delq nil res)) + (when user + (dolist (x res) + (setcar x user))) + (setq res (delete-dups res)) + (let* ((old-ivy-last ivy-last) + (enable-recursive-minibuffers t) + (host (let ((ivy-auto-select-single-candidate nil)) + (ivy-read "user@host: " + (mapcar #'ivy-build-tramp-name res) + :initial-input rest)))) + (setq ivy-last old-ivy-last) + (when host + (setq ivy--directory "/") + (ivy--cd (concat "/" method ":" host ":/")))))) + +(defun ivy--directory-done () + "Handle exit from the minibuffer when completing file names." + (let ((dir (ivy--handle-directory ivy-text))) + (cond ((equal (ivy-state-current ivy-last) (ivy-state-def ivy-last)) + (ivy-done)) + ((and (ivy-state-require-match ivy-last) + (equal ivy-text "") + (null ivy--old-cands)) + (ivy-immediate-done)) + (dir + (let ((inhibit-message t)) + (ivy--cd dir))) + ((ivy--directory-enter)) + ((unless (string= ivy-text "") + ;; Obsolete since 26.1 and removed in 28.1. + (defvar tramp-completion-mode) + (with-no-warnings + (let* ((tramp-completion-mode t) + ;; Alternative to `tramp-completion-mode' in newer Tramp. + (non-essential t) + ;; Non-nil changes completion since Tramp 2.6.0.2. + (minibuffer-completing-file-name nil) + (file (expand-file-name + (if (> ivy--length 0) (ivy-state-current ivy-last) ivy-text) + ivy--directory))) + (when (ignore-errors (file-exists-p file)) + (if (file-directory-p file) + (ivy--cd (file-name-as-directory file)) + (ivy-done)) + ivy-text))))) + ((or (and (equal ivy--directory "/") + (string-match-p "\\`[^/]+:.*:.*\\'" ivy-text)) + (string-match-p "\\`/[^/]+:.*:.*\\'" ivy-text)) + (ivy-done)) + ((ivy--tramp-prefix-p) + (ivy--tramp-candidates)) + (t + (ivy-done))))) + +(defun ivy--tramp-prefix-p () + (or (and (equal ivy--directory "/") + (cond ((string-match + "\\`\\([^/]+?\\):\\(?:\\(.*\\)@\\)?\\(.*\\)\\'" + ivy-text) + (save-match-data + (ivy-set-text (ivy-state-current ivy-last)))) + ((string-match + "\\`\\([^/]+?\\):\\(?:\\(.*\\)@\\)?\\(.*\\)\\'" + (ivy-state-current ivy-last)) + (save-match-data + (ivy-set-text (ivy-state-current ivy-last)))))) + (string-match + "\\`/\\([^/]+?\\):\\(?:\\(.*\\)@\\)?\\(.*\\)\\'" + ivy-text))) + +(defun ivy-expand-file-if-directory (file-name) + "Expand FILE-NAME as directory. +When this directory doesn't exist, return nil." + (when (stringp file-name) + (let ((full-name + ;; Ignore host name must not match method "ssh" + (ignore-errors + (file-name-as-directory + (expand-file-name file-name ivy--directory))))) + (when (and full-name (file-directory-p full-name)) + full-name)))) + +(defcustom ivy-tab-space nil + "When non-nil, `ivy-partial-or-done' should insert a space." + :type 'boolean) + +(defun ivy-partial-or-done () + "Complete the minibuffer text as much as possible. +If the text hasn't changed as a result, forward to `ivy-alt-done'." + (interactive) + (cond + ((and (numberp completion-cycle-threshold) + (< (length ivy--all-candidates) completion-cycle-threshold)) + (let ((ivy-wrap t)) + (ivy-next-line))) + ((and (eq (ivy-state-collection ivy-last) #'read-file-name-internal) + (or (and (equal ivy--directory "/") + (string-match-p "\\`[^/]+:.*\\'" ivy-text)) + (= (string-to-char ivy-text) ?/))) + (let ((default-directory ivy--directory) + dir) + (minibuffer-complete) + (ivy-set-text (ivy--input)) + (when (setq dir (ivy-expand-file-if-directory ivy-text)) + (ivy--cd dir)))) + (t + (or (ivy-partial) + (when (or (eq this-command last-command) + (eq ivy--length 1)) + (ivy-alt-done)))))) + +(defun ivy--partial-cd-for-single-directory () + (when (and + (eq (ivy-state-collection ivy-last) #'read-file-name-internal) + (= 1 (length + (ivy--re-filter + (funcall ivy--regex-function + (concat "^" (string-remove-prefix "^" ivy-text))) + ivy--all-candidates))) + (let ((default-directory ivy--directory)) + (file-directory-p (ivy-state-current ivy-last)))) + (ivy--directory-done))) + +(defun ivy-partial () + "Complete the minibuffer text as much as possible." + (interactive) + (if (ivy-state-dynamic-collection ivy-last) + (let* ((bnd + (ignore-errors + (funcall + (ivy-state-collection ivy-last) + ivy-text nil (cons 'boundaries (buffer-substring (point) (line-end-position)))))) + (beg (+ (minibuffer-prompt-end) + (if bnd (cadr bnd) 0)))) + (delete-region beg (point-max)) + (insert + (ivy-state-current ivy-last)) + t) + (let* ((parts (or (ivy--split-spaces ivy-text) (list ""))) + (tail (last parts)) + (postfix (car tail)) + (case-fold-search (ivy--case-fold-p ivy-text)) + (completion-ignore-case case-fold-search) + (new (try-completion (string-remove-prefix "^" postfix) + (mapcar (lambda (str) + (let ((i (string-match-p postfix str))) + (and i (substring str i)))) + ivy--old-cands)))) + (cond + ((eq new t) nil) + ((string= new ivy-text) nil) + ((string= (car tail) (car (ivy--split-spaces new))) nil) + (new + (delete-region (minibuffer-prompt-end) (point-max)) + (setcar tail + (if (= (string-to-char postfix) ?^) + (concat "^" new) + new)) + (ivy-set-text + (concat + (mapconcat #'identity parts " ") + (and ivy-tab-space (not (= (length ivy--old-cands) 1)) " "))) + (insert ivy-text) + (ivy--partial-cd-for-single-directory) + t))))) + +(defvar ivy-completion-beg nil + "Completion bounds start.") + +(defvar ivy-completion-end nil + "Completion bounds end.") + +(defun ivy-immediate-done () + "Exit the minibuffer with current input instead of current candidate." + (interactive) + (delete-minibuffer-contents) + (setf (ivy-state-current ivy-last) + (cond ((or (not ivy--directory) + (eq (ivy-state-history ivy-last) 'grep-files-history)) + ivy-text) + ((and (string= ivy-text "") + (eq (ivy-state-collection ivy-last) + #'read-file-name-internal)) + (if (ivy-state-def ivy-last) + (if (and + (file-exists-p (ivy-state-def ivy-last)) + (/= (length ivy--directory) + (1+ (length (expand-file-name (ivy-state-def ivy-last)))))) + ivy--directory + (copy-sequence (ivy-state-def ivy-last))) + ivy--directory)) + (t + (expand-file-name ivy-text ivy--directory)))) + (insert (ivy-state-current ivy-last)) + (setq ivy-completion-beg ivy-completion-end) + (setq ivy-exit 'done) + (exit-minibuffer)) + +(defun ivy--restore-session (&optional session) + "Resume a recorded completion SESSION, if any exists." + (when ivy--sessions + (unless session + (setq session (intern + (let ((ivy-last ivy-last) + ivy--all-candidates + ivy-text) + (ivy-read "Choose ivy session: " + ivy--sessions + :require-match t))))) + (setq ivy-last (or (cdr (assq session ivy--sessions)) + ivy-last))) + (let ((data (plist-get (ivy-state-extra-props ivy-last) :ivy-data))) + (when data + (setq ivy--all-candidates (plist-get data :all-candidates)) + (setq ivy-text (plist-get data :text))))) + +;;;###autoload +(defun ivy-resume (&optional session) + "Resume the last completion session, or SESSION if non-nil. +With a prefix arg, try to restore a recorded completion session, +if one exists." + (interactive) + (when (or current-prefix-arg session) + (ivy--restore-session session)) + + (if (or (null (ivy-state-action ivy-last)) + (eq (ivy--get-action ivy-last) #'identity)) + (user-error "The last session isn't compatible with `ivy-resume'") + (when (memq (ivy-state-caller ivy-last) + '(swiper + swiper-isearch swiper-backward + swiper-isearch-backward + counsel-grep)) + (switch-to-buffer (ivy-state-buffer ivy-last))) + (with-current-buffer (ivy-state-buffer ivy-last) + (let ((default-directory (ivy-state-directory ivy-last)) + (ivy-use-ignore-default (ivy-state-ignore ivy-last))) + (ivy-read + (ivy-state-prompt ivy-last) + (ivy-state-collection ivy-last) + :predicate (ivy-state-predicate ivy-last) + :require-match (ivy-state-require-match ivy-last) + :initial-input ivy-text + :history (ivy-state-history ivy-last) + :preselect (ivy-state-current ivy-last) + :keymap (ivy-state-keymap ivy-last) + :update-fn (ivy-state-update-fn ivy-last) + :sort (ivy-state-sort ivy-last) + :action (ivy-state-action ivy-last) + :unwind (ivy-state-unwind ivy-last) + :re-builder (ivy-state-re-builder ivy-last) + :matcher (ivy-state-matcher ivy-last) + :dynamic-collection (ivy-state-dynamic-collection ivy-last) + :extra-props (ivy-state-extra-props ivy-last) + :caller (ivy-state-caller ivy-last)))))) + +(defvar-local ivy-calling nil + "When non-nil, call the current action when `ivy--index' changes.") + +(defun ivy-set-index (index) + "Set `ivy--index' to INDEX." + (setq ivy--index index) + (when ivy-calling + (ivy--exhibit) + (ivy-call))) + +(defun ivy-beginning-of-buffer () + "Select the first completion candidate." + (interactive) + (ivy-set-index 0)) + +(defun ivy-end-of-buffer () + "Select the last completion candidate." + (interactive) + (ivy-set-index (1- ivy--length))) + +(defun ivy-scroll-up-command () + "Scroll the candidates upward by the minibuffer height." + (interactive) + (ivy-set-index (min (1- (+ ivy--index ivy-height)) + (1- ivy--length)))) + +(defun ivy-scroll-down-command () + "Scroll the candidates downward by the minibuffer height." + (interactive) + (ivy-set-index (max (1+ (- ivy--index ivy-height)) + 0))) + +(defun ivy-next-line (&optional arg) + "Move cursor vertically down ARG candidates." + (interactive "p") + (setq arg (or arg 1)) + (let ((index (+ ivy--index arg))) + (if (> index (1- ivy--length)) + (if ivy-wrap + (ivy-beginning-of-buffer) + (ivy-set-index (1- ivy--length))) + (ivy-set-index index)))) + +(defun ivy-next-line-or-history (&optional arg) + "Move cursor vertically down ARG candidates. +If the input is empty, select the previous history element instead." + (interactive "p") + (let ((orig-index ivy--index)) + (ivy-next-line arg) + (when (and (string= ivy-text "") (= ivy--index orig-index)) + (ivy-previous-history-element 1)))) + +(defun ivy-previous-line (&optional arg) + "Move cursor vertically up ARG candidates." + (interactive "p") + (setq arg (or arg 1)) + (let ((index (- ivy--index arg)) + (min-index (if ivy--use-selectable-prompt -1 0))) + (if (< index min-index) + (if ivy-wrap + (ivy-end-of-buffer) + (ivy-set-index min-index)) + (ivy-set-index index)))) + +(defun ivy-previous-line-or-history (arg) + "Move cursor vertically up ARG candidates. +If the input is empty, select the previous history element instead." + (interactive "p") + (let ((orig-index ivy--index)) + (ivy-previous-line arg) + (when (and (string= ivy-text "") (= ivy--index orig-index)) + (ivy-previous-history-element 1)))) + +(defun ivy-toggle-calling () + "Flip `ivy-calling'." + (interactive) + (when (setq ivy-calling (not ivy-calling)) + (ivy-call))) + +(defun ivy-toggle-ignore () + "Toggle user-configured candidate filtering." + (interactive) + (setq ivy-use-ignore + (if ivy-use-ignore + nil + (or ivy-use-ignore-default t))) + (setf (ivy-state-ignore ivy-last) ivy-use-ignore) + ;; invalidate cache + (setq ivy--old-cands nil)) + +(defun ivy--get-action (state) + "Get the action function from STATE." + (let ((action (ivy-state-action state))) + (when action + (if (functionp action) + action + (cadr (nth (car action) action)))))) + +(defun ivy--get-multi-action (state) + "Get the multi-action function from STATE." + (let* ((action (ivy-state-action state)) + (multi-action + (and (listp action) + (not (eq (car action) 'lambda)) + (nth 3 (nth (car action) action))))) + (if multi-action + multi-action + (when (eq (car action) 1) + (ivy-state-multi-action state))))) + +(defun ivy--get-window (state) + "Get the window from STATE." + (if (ivy-state-p state) + (let ((window (ivy-state-window state))) + (if (window-live-p window) + window + (next-window))) + (selected-window))) + +(defun ivy--actionp (x) + "Return non-nil when X is a list of actions." + (and (consp x) (not (memq (car x) '(closure lambda))))) + +(defcustom ivy-action-wrap nil + "When non-nil, `ivy-next-action' and `ivy-prev-action' wrap." + :type 'boolean) + +(defun ivy-next-action () + "When the current action is a list, scroll it forwards." + (interactive) + (let ((action (ivy-state-action ivy-last))) + (when (ivy--actionp action) + (let ((len (1- (length action))) + (idx (car action))) + (if (>= idx len) + (when ivy-action-wrap + (setf (car action) 1)) + (cl-incf (car action))))))) + +(defun ivy-prev-action () + "When the current action is a list, scroll it backwards." + (interactive) + (let ((action (ivy-state-action ivy-last))) + (when (ivy--actionp action) + (if (<= (car action) 1) + (when ivy-action-wrap + (setf (car action) (1- (length action)))) + (cl-decf (car action)))))) + +(defun ivy-action-name () + "Return the name associated with the current action." + (let ((action (ivy-state-action ivy-last))) + (if (ivy--actionp action) + (format "[%d/%d] %s" + (car action) + (1- (length action)) + (nth 2 (nth (car action) action))) + "[1/1] default"))) + +(defvar ivy-inhibit-action nil + "When non-nil, `ivy-call' does nothing. + +Example use: + + (let* ((ivy-inhibit-action t) + (str (ivy-switch-buffer))) + ;; do whatever with str - the corresponding buffer will not be opened + )") + +(defun ivy-recursive-restore () + "Restore the above state when exiting the minibuffer. +See variable `ivy-recursive-restore' for further information." + (when (and ivy-recursive-last + ivy-recursive-restore + (not (eq ivy-last ivy-recursive-last))) + (ivy--reset-state (setq ivy-last ivy-recursive-last)))) + +(defvar ivy-mark-prefix ">" + "Prefix used by `ivy-mark'.") + +(defun ivy--call-marked (action) + (let* ((prefix-len (length ivy-mark-prefix)) + (marked-candidates + (mapcar + (lambda (s) + (let ((cand (substring s prefix-len))) + (if ivy--directory + (expand-file-name cand ivy--directory) + cand))) + ivy-marked-candidates)) + (multi-action (ivy--get-multi-action ivy-last))) + (if multi-action + (let ((default-directory (ivy-state-directory ivy-last))) + (funcall multi-action (mapcar #'ivy--call-cand marked-candidates))) + (dolist (c marked-candidates) + (let ((default-directory (ivy-state-directory ivy-last))) + (funcall action (ivy--call-cand c))))))) + +(defun ivy--call-cand (current) + (let ((collection (ivy-state-collection ivy-last))) + (cond + ;; Alist type. + ((and (consp (car-safe collection)) + ;; Previously, the cdr of the selected + ;; candidate would be returned. Now, the + ;; whole candidate is returned. + (let ((idx (get-text-property 0 'idx current))) + (if idx + (progn + (ivy--remove-props current 'idx) + (nth idx collection)) + (assoc current collection))))) + (ivy--directory + (expand-file-name current ivy--directory)) + ((equal current "") + ivy-text) + (t + current)))) + +(defun ivy-call () + "Call the current action without exiting completion." + (interactive) + ;; Testing with `ivy-with' seems to call `ivy-call' again, + ;; in which case `this-command' is nil; so check for this. + (unless (memq this-command '(nil + ivy-done + ivy-alt-done + ivy-dispatching-done)) + (setq ivy-current-prefix-arg current-prefix-arg)) + (let* ((action + (if (functionp ivy-inhibit-action) + ivy-inhibit-action + (and (not ivy-inhibit-action) + (ivy--get-action ivy-last)))) + (current (ivy-state-current ivy-last)) + (x (ivy--call-cand current)) + (res + (cond + ((null action) + current) + (t + (select-window (ivy--get-window ivy-last)) + (set-buffer (ivy-state-buffer ivy-last)) + (prog1 (unwind-protect + (if ivy-marked-candidates + (ivy--call-marked action) + (funcall action x)) + (ivy-recursive-restore)) + (unless (or (eq ivy-exit 'done) + (minibuffer-window-active-p (selected-window)) + (null (active-minibuffer-window))) + (select-window (active-minibuffer-window)))))))) + (if ivy-inhibit-action + res + current))) + +(defun ivy-call-and-recenter () + "Call action and recenter window according to the selected candidate." + (interactive) + (ivy-call) + (with-ivy-window + (recenter-top-bottom))) + +(defun ivy-next-line-and-call (&optional arg) + "Move cursor vertically down ARG candidates. +Call the permanent action if possible." + (interactive "p") + (ivy-next-line arg) + (ivy--exhibit) + (ivy-call)) + +(defun ivy-previous-line-and-call (&optional arg) + "Move cursor vertically up ARG candidates. +Call the permanent action if possible." + (interactive "p") + (ivy-previous-line arg) + (ivy--exhibit) + (ivy-call)) + +(defun ivy-previous-history-element (arg) + "Forward to `previous-history-element' with ARG." + (interactive "p") + (previous-history-element arg) + (ivy--cd-maybe) + (move-end-of-line 1) + (ivy--maybe-scroll-history)) + +(defun ivy--insert-symbol-boundaries () + (undo-boundary) + (beginning-of-line) + (insert "\\_<") + (end-of-line) + (insert "\\_>")) + +(defun ivy-next-history-element (arg) + "Forward to `next-history-element' with ARG." + (interactive "p") + (if (and (= minibuffer-history-position 0) + (equal ivy-text "")) + (progn + (when minibuffer-default + (setq ivy--default (car minibuffer-default))) + (insert ivy--default) + (when (and (with-ivy-window (derived-mode-p 'prog-mode)) + (eq (ivy-state-caller ivy-last) 'swiper) + (not (file-exists-p ivy--default)) + (not (ivy-ffap-url-p ivy--default)) + (not (ivy-state-dynamic-collection ivy-last)) + (> (point) (minibuffer-prompt-end))) + (ivy--insert-symbol-boundaries))) + (next-history-element arg)) + (ivy--cd-maybe) + (move-end-of-line 1) + (ivy--maybe-scroll-history)) + +(defvar ivy-ffap-url-functions nil + "List of functions that check if the point is on a URL.") + +(defun ivy--cd-maybe () + "Check if the current input points to a different directory. +If so, move to that directory, while keeping only the file name." + (when ivy--directory + (let ((input (ivy--input)) + url) + (if (setq url (or (ivy-ffap-url-p input) + (with-ivy-window + (cl-reduce + (lambda (a b) + (or a (funcall b))) + ivy-ffap-url-functions + :initial-value nil)))) + (ivy-exit-with-action + (lambda (_) + (ivy-ffap-url-fetcher url)) + 'no-update-history) + (setq input (expand-file-name input)) + (let ((file (file-name-nondirectory input)) + (dir (expand-file-name (file-name-directory input)))) + (if (string= dir ivy--directory) + (progn + (delete-minibuffer-contents) + (insert file)) + (ivy--cd dir) + (insert file))))))) + +(defun ivy--maybe-scroll-history () + "If the selected history element has an index, scroll there." + (let ((idx (ignore-errors + (get-text-property + (minibuffer-prompt-end) + 'ivy-index)))) + (when idx + (ivy--exhibit) + (ivy-set-index idx)))) + +(declare-function tramp-get-completion-methods "tramp") + +(defun ivy--cd (dir) + "When completing file names, move to directory DIR." + (if (ivy--completing-fname-p) + (progn + (push dir ivy--directory-hist) + (setq ivy--old-cands nil) + (setq ivy--old-re nil) + (ivy-set-index 0) + (setq ivy--all-candidates + (append + (ivy--sorted-files (setq ivy--directory dir)) + (when (and (string= dir "/") (featurep 'tramp)) + (sort + (mapcar + (lambda (s) (substring s 1)) + (tramp-get-completion-methods "")) + #'string<)))) + (ivy-set-text "") + (setf (ivy-state-directory ivy-last) dir) + (delete-minibuffer-contents)) + (error "Unexpected"))) + +(defun ivy--parent-dir (filename) + "Return parent directory of absolute FILENAME." + (file-name-directory (directory-file-name filename))) + +(defun ivy-backward-delete-char () + "Forward to `delete-backward-char'. +Call `ivy-on-del-error-function' if an error occurs, usually when +there is no more text to delete at the beginning of the +minibuffer." + (interactive) + (if (and ivy--directory (= (minibuffer-prompt-end) (point))) + (progn + (ivy--cd (ivy--parent-dir (expand-file-name ivy--directory))) + (ivy--exhibit)) + (setq prefix-arg current-prefix-arg) + (condition-case nil + (call-interactively #'delete-backward-char) + (error + (when ivy-on-del-error-function + (funcall ivy-on-del-error-function)))))) + +(defun ivy-delete-char (arg) + "Forward to `delete-char' ARG." + (interactive "p") + (unless (eolp) + (delete-char arg))) + +(defun ivy-forward-char (arg) + "Forward to `forward-char' ARG." + (interactive "p") + (unless (eolp) + (forward-char arg))) + +(defun ivy-kill-word (arg) + "Forward to `kill-word' ARG." + (interactive "p") + (unless (eolp) + (kill-word arg))) + +(defun ivy-kill-line () + "Forward to `kill-line'." + (interactive) + (if (eolp) + (progn + (kill-region (minibuffer-prompt-end) (point)) + (setq ivy--old-text (current-kill 0 t))) + (kill-line))) + +(defun ivy-kill-whole-line () + "Forward to `kill-whole-line'." + (interactive) + (kill-region (minibuffer-prompt-end) (line-end-position))) + +(defun ivy-backward-kill-word () + "Forward to `backward-kill-word'." + (interactive) + (if (and ivy--directory (= (minibuffer-prompt-end) (point))) + (progn + (ivy--cd (ivy--parent-dir (expand-file-name ivy--directory))) + (ivy--exhibit)) + (ignore-errors + (let ((pt (point)) + (last-command (if (eq last-command 'ivy-backward-kill-word) + 'kill-region + last-command))) + (forward-word -1) + (kill-region pt (point)))))) + +(defvar ivy--regexp-quote #'regexp-quote + "Store the regexp quoting state.") + +(defun ivy-toggle-regexp-quote () + "Toggle the regexp quoting." + (interactive) + (setq ivy--old-re nil) + (cl-rotatef ivy--regex-function ivy--regexp-quote) + (setq ivy--old-text "") + (setq ivy-regex (funcall ivy--regex-function ivy-text))) + +(defcustom ivy-format-functions-alist + '((t . ivy-format-function-default)) + "An alist of functions that transform the list of candidates into a string. +This string is inserted into the minibuffer." + :type '(alist + :key-type symbol + :value-type + (choice + (const :tag "Default" ivy-format-function-default) + (const :tag "Arrow prefix" ivy-format-function-arrow) + (const :tag "Full line" ivy-format-function-line) + (const :tag "Arrow prefix + full line" + ivy-format-function-arrow-line) + (function :tag "Custom function")))) + +(defun ivy-sort-file-function-default (x y) + "Compare two files X and Y. +Prioritize directories." + (let ((xdir (get-text-property 0 'ivy--dir x)) + (ydir (get-text-property 0 'ivy--dir y))) + (if xdir + (or (not ydir) (string< xdir ydir)) + (and (not ydir) (string< x y))))) + +(defun ivy-string< (x y) + "Like `string<', but operate on CARs when given cons cells." + (string< (if (consp x) (car x) x) + (if (consp y) (car y) y))) + +(define-obsolete-function-alias 'ivy-sort-file-function-using-ido + 'ido-file-extension-lessp "0.13.0 (2019-10-12)") + +(defcustom ivy-sort-functions-alist + '((t . ivy-string<)) + "An alist of sorting functions for each collection function. +Interactive functions that call completion fit in here as well. + +Nil means no sorting, which is useful to turn off the sorting for +functions that have candidates in the natural buffer order, like +`org-refile' or `Man-goto-section'. + +A list can be used to associate multiple sorting functions with a +collection. The car of the list is the current sort +function. This list can be rotated with `ivy-rotate-sort'. + +The entry associated with t is used for all fall-through cases. + +See also `ivy-sort-max-size'." + :type + '(alist + :key-type (choice + (const :tag "Fall-through" t) + (symbol :tag "Collection")) + :value-type (choice + (const :tag "Plain sort" ivy-string<) + (const :tag "File sort" ivy-sort-file-function-default) + (const :tag "File sort using Ido" ido-file-extension-lessp) + (const :tag "No sort" nil) + (function :tag "Custom function") + (repeat (function :tag "Custom function"))))) + +(defun ivy--sort-function (collection) + "Retrieve sort function for COLLECTION from `ivy-sort-functions-alist'." + (let ((entry (cdr (or (assq collection ivy-sort-functions-alist) + (assq (ivy-state-caller ivy-last) ivy-sort-functions-alist) + (assq t ivy-sort-functions-alist))))) + (and (or (functionp entry) + (functionp (setq entry (car-safe entry)))) + entry))) + +(defun ivy-rotate-sort () + "Rotate through sorting functions available for current collection. +This only has an effect if multiple sorting functions are +specified for the current collection in +`ivy-sort-functions-alist'." + (interactive) + (let ((cell (or (assq (ivy-state-collection ivy-last) ivy-sort-functions-alist) + (assq (ivy-state-caller ivy-last) ivy-sort-functions-alist) + (assq t ivy-sort-functions-alist)))) + (when (consp (cdr cell)) + (setcdr cell (nconc (cddr cell) (list (cadr cell)))) + (ivy--reset-state ivy-last)))) + +(defcustom ivy-index-functions-alist + '((t . ivy-recompute-index-zero)) + "An alist of index recomputing functions for each collection function. +When the input changes, the appropriate function returns an +integer - the index of the matched candidate that should be +selected." + :type '(alist :key-type symbol :value-type function)) + +(defvar ivy-re-builders-alist + '((t . ivy--regex-plus)) + "An alist of regex building functions for each collection function. + +Each key is (in order of priority): +1. The actual collection function, e.g. `read-file-name-internal'. +2. The symbol passed by :caller into `ivy-read'. +3. `this-command'. +4. t. + +Each value is a function that should take a string and return a +valid regex or a regex sequence (see below). + +Possible choices: `ivy--regex', `regexp-quote', +`ivy--regex-plus', `ivy--regex-fuzzy', `ivy--regex-ignore-order'. + +If a function returns a list, it should format like this: +\\='((\"matching-regexp\" . t) (\"non-matching-regexp\") ...). + +The matches will be filtered in a sequence, you can mix the +regexps that should match and that should not match as you +like.") + +(defvar ivy-highlight-functions-alist + '((ivy--regex-ignore-order . ivy--highlight-ignore-order) + (ivy--regex-fuzzy . ivy--highlight-fuzzy) + (ivy--regex-plus . ivy--highlight-default)) + "An alist of highlighting functions for each regex builder function.") + +(defcustom ivy-initial-inputs-alist + '((org-refile . "^") + (org-agenda-refile . "^") + (org-capture-refile . "^") + (Man-completion-table . "^") + (woman . "^")) + "An alist associating commands with their initial input. + +Each cdr is either a string or a function called in the context +of a call to `ivy-read'." + :type '(alist + :key-type (symbol) + :value-type (choice (string) (function)))) + +(defcustom ivy-hooks-alist nil + "An alist associating commands to setup functions. +Examples: `toggle-input-method', (lambda () (insert \"^\")), etc. +May supersede `ivy-initial-inputs-alist'." + :type '(alist :key-type symbol :value-type function)) + +(defvar ivy--occurs-list nil + "A list of custom occur generators per command.") + +(defun ivy-set-occur (cmd occur) + "Assign CMD a custom OCCUR function." + (setq ivy--occurs-list + (plist-put ivy--occurs-list cmd occur))) + +(defcustom ivy-update-fns-alist nil + "An alist associating commands to their :update-fn values." + :type '(alist + :key-type symbol + :value-type + (radio + (const :tag "Off" nil) + (const :tag "Call action on change" auto)))) + +(defcustom ivy-unwind-fns-alist nil + "An alist associating commands to their :unwind values." + :type '(alist :key-type symbol :value-type function)) + +(defcustom ivy-init-fns-alist nil + "An alist associating commands to their :init values. +An :init is a function with no arguments. +`ivy-read' calls it to initialize." + :type '(alist :key-type symbol :value-type function)) + +(defun ivy--alist-set (alist-sym key val) + (let ((curr-val (symbol-value alist-sym)) + (customized-val (get alist-sym 'customized-value)) + (default-val (eval (car (get alist-sym 'standard-value))))) + ;; when the value was set by `customize-set-variable', don't touch it + (unless customized-val + ;; only works if the value wasn't customized by the user + (when (or (null default-val) (equal curr-val default-val)) + (let ((cell (assoc key curr-val))) + (if cell + (setcdr cell val) + (set alist-sym (cons (cons key val) + (symbol-value alist-sym))))) + (when default-val + (put alist-sym 'standard-value + (list (list 'quote (symbol-value alist-sym))))))))) + +(declare-function counsel-set-async-exit-code "counsel") + +(defvar ivy--parents-alist nil + "Configure parent caller for child caller. +The child caller inherits and can override the settings of the parent.") + +(cl-defun ivy-configure (caller + &key + parent + initial-input + height + occur + update-fn + init-fn + unwind-fn + index-fn + sort-fn + sort-matches-fn + format-fn + display-fn + display-transformer-fn + alt-done-fn + more-chars + grep-p + exit-codes) + "Configure `ivy-read' params for CALLER." + (declare (indent 1)) + (when parent + (ivy--alist-set 'ivy--parents-alist caller parent)) + (when initial-input + (ivy--alist-set 'ivy-initial-inputs-alist caller initial-input)) + (when height + (ivy--alist-set 'ivy-height-alist caller height)) + (when occur + (ivy-set-occur caller occur)) + (when update-fn + (ivy--alist-set 'ivy-update-fns-alist caller update-fn)) + (when unwind-fn + (ivy--alist-set 'ivy-unwind-fns-alist caller unwind-fn)) + (when init-fn + (ivy--alist-set 'ivy-init-fns-alist caller init-fn)) + (when index-fn + (ivy--alist-set 'ivy-index-functions-alist caller index-fn)) + (when sort-fn + (ivy--alist-set 'ivy-sort-functions-alist caller sort-fn)) + (when sort-matches-fn + (ivy--alist-set 'ivy-sort-matches-functions-alist caller sort-matches-fn)) + (when format-fn + (ivy--alist-set 'ivy-format-functions-alist caller format-fn)) + (when display-fn + (ivy--alist-set 'ivy-display-functions-alist caller display-fn)) + (when display-transformer-fn + (ivy--alist-set 'ivy--display-transformers-alist caller display-transformer-fn)) + (when alt-done-fn + (ivy--alist-set 'ivy-alt-done-functions-alist caller alt-done-fn)) + (when more-chars + (ivy--alist-set 'ivy-more-chars-alist caller more-chars)) + (when grep-p + (cl-pushnew caller ivy-highlight-grep-commands)) + (when exit-codes + (let (code msg) + (while (and (setq code (pop exit-codes)) + (setq msg (pop exit-codes))) + (counsel-set-async-exit-code caller code msg))))) + +(defcustom ivy-sort-max-size 30000 + "Sorting won't be done for collections larger than this." + :type 'integer) + +(defalias 'ivy--dirname-p + ;; Added in Emacs 25.1. + (if (fboundp 'directory-name-p) + #'directory-name-p + (lambda (name) + "Return non-nil if NAME ends with a directory separator." + (string-suffix-p "/" name)))) + +(defalias 'ivy--string-search + (if (fboundp 'string-search) + #'string-search + (lambda (needle haystack) ;; Faster than `cl-search'. + (string-match-p (regexp-quote needle) haystack))) + "Compatibility shim for Emacs 28 `string-search'. +\n(fn NEEDLE HAYSTACK)") + +(defalias 'ivy--string-replace + (if (fboundp 'string-replace) + #'string-replace + (lambda (from to in) + (replace-regexp-in-string (regexp-quote from) to in t t))) + "Compatibility shim for Emacs 28 `string-replace'. +\n(fn FROM TO IN)") + +;; Moved to subr.el in Emacs 27.1. +(autoload 'xor "array") + +(defun ivy--sorted-files (dir) + "Return the list of files in DIR. +Directories come first." + (let* ((coll #'read-file-name-internal) + (sort-fn (ivy--sort-function coll)) + (dirs-first (eq sort-fn #'ivy-sort-file-function-default)) + (seq (cl-mapcan + (lambda (f) + (unless (member f '("./" "../")) + ;; FIXME: Use `substitute-in-file-name'? + ;; Re: #2012, #3060. + (setq f (ivy--string-replace "$$" "$" f)) + (list (if (and dirs-first (ivy--dirname-p f)) + (propertize f 'ivy--dir (directory-file-name f)) + f)))) + (condition-case nil + (let ((default-directory dir)) + (all-completions "" coll (ivy-state-predicate ivy-last))) + (error (directory-files + dir nil directory-files-no-dot-files-regexp)))))) + (when sort-fn + (setq seq (sort seq sort-fn))) + (dolist (extra ivy-extra-directories) + (push extra seq)) + (if (string= dir "/") + (cl-delete-if (lambda (s) (string-suffix-p ":" s)) (delete "../" seq)) + seq))) + +(defun ivy-alist-setting (alist &optional key) + "Return the value associated with KEY in ALIST, using `assq'. +KEY defaults to the last caller of `ivy-read'; if no entry is +found, it falls back to the key t." + (let ((caller (or key (ivy-state-caller ivy-last)))) + (or + (and caller (cdr (assq caller alist))) + (let ((parent (cdr (assq caller ivy--parents-alist)))) + (when parent + (ivy-alist-setting alist parent))) + (cdr (assq t alist))))) + +(defun ivy--height (caller) + (let ((v (or (ivy-alist-setting ivy-height-alist caller) + ivy-height))) + (if (integerp v) + v + (if (functionp v) + (funcall v caller) + (error "Unexpected value: %S" v))))) + +(defun ivy--remove-props (str &rest props) + "Return STR with text PROPS destructively removed." + (ignore-errors + (remove-list-of-text-properties 0 (length str) props str)) + str) + +(defun ivy--update-prompt (prompt) + (cond ((equal prompt "Keyword, C-h: ") + ;; auto-insert.el + "Keyword (C-M-j to end): ") + (t + ;; misearch.el + (ivy--string-replace "RET to end" "C-M-j to end" prompt)))) + +;;;; Entry Point + +;;;###autoload +(cl-defun ivy-read (prompt collection + &key + predicate require-match initial-input + history preselect def keymap update-fn sort + action multi-action + unwind re-builder matcher + dynamic-collection + extra-props + caller) + "Read a string in the minibuffer, with completion. + +PROMPT is a string, normally ending in a colon and a space. +`ivy-count-format' is prepended to PROMPT during completion. + +COLLECTION is either a list of strings, a function, an alist, or +a hash table, supplied for `minibuffer-completion-table'. + +PREDICATE is applied to filter out the COLLECTION immediately. +This argument is for compatibility with `completing-read'. + +When REQUIRE-MATCH is non-nil, only members of COLLECTION can be +selected. In can also be a lambda. + +If INITIAL-INPUT is non-nil, then insert that input in the +minibuffer initially. + +HISTORY is a name of a variable to hold the completion session +history. + +KEYMAP is composed with `ivy-minibuffer-map'. + +PRESELECT, when non-nil, determines which one of the candidates +matching INITIAL-INPUT to select initially. An integer stands +for the position of the desired candidate in the collection, +counting from zero. Otherwise, use the first occurrence of +PRESELECT in the collection. Comparison is first done with +`equal'. If that fails, and when applicable, match PRESELECT as +a regular expression. + +DEF is for compatibility with `completing-read'. + +UPDATE-FN is called each time the candidate list is re-displayed. + +When SORT is non-nil, `ivy-sort-functions-alist' determines how +to sort candidates before displaying them. + +ACTION is a function to call after selecting a candidate. +It takes one argument, the selected candidate. If COLLECTION is +an alist, the argument is a cons cell, otherwise it's a string. + +MULTI-ACTION, when non-nil, is called instead of ACTION when +there are marked candidates. It takes the list of candidates as +its only argument. When it's nil, ACTION is called on each marked +candidate. + +UNWIND is a function of no arguments to call before exiting. + +RE-BUILDER is a function transforming input text into a regex +pattern. + +MATCHER is a function which can override how candidates are +filtered based on user input. It takes a regex pattern and a +list of candidates, and returns the list of matching candidates. + +DYNAMIC-COLLECTION is a boolean specifying whether the list of +candidates is updated after each input by calling COLLECTION. + +EXTRA-PROPS is a plist that can be used to store +collection-specific session-specific data. + +CALLER is a symbol to uniquely identify the caller to `ivy-read'. +It is used, along with COLLECTION, to determine which +customizations apply to the current completion session." + (let ((init-fn (ivy-alist-setting ivy-init-fns-alist caller))) + (when init-fn + (funcall init-fn))) + ;; get un-stuck from an existing `read-key' overriding minibuffer keys + (when (equal overriding-local-map '(keymap)) + (keyboard-quit)) + (setq caller (or caller this-command)) + (let* ((ivy-recursive-last (and (active-minibuffer-window) ivy-last)) + (ivy--display-function + (when (or ivy-recursive-last + (not (window-minibuffer-p))) + (ivy-alist-setting ivy-display-functions-alist caller)))) + (setq update-fn (or update-fn (ivy-alist-setting ivy-update-fns-alist caller))) + (setq unwind (or unwind (ivy-alist-setting ivy-unwind-fns-alist caller))) + (setq ivy-last + (make-ivy-state + :prompt (ivy--update-prompt prompt) + :collection collection + :predicate predicate + :require-match require-match + :initial-input initial-input + :history history + :preselect preselect + :keymap keymap + :update-fn (if (eq update-fn 'auto) + (lambda () + (with-ivy-window + (funcall + (ivy--get-action ivy-last) + (if (consp (car-safe (ivy-state-collection ivy-last))) + (assoc (ivy-state-current ivy-last) + (ivy-state-collection ivy-last)) + (ivy-state-current ivy-last))))) + update-fn) + :sort sort + :action (ivy--compute-extra-actions action caller) + :multi-action multi-action + :frame (selected-frame) + :window (selected-window) + :buffer (current-buffer) + :unwind unwind + :re-builder re-builder + :matcher matcher + :dynamic-collection dynamic-collection + :display-transformer-fn (ivy-alist-setting ivy--display-transformers-alist caller) + :directory default-directory + :extra-props extra-props + :caller caller + :def def)) + (ivy--reset-state ivy-last) + (unwind-protect + (minibuffer-with-setup-hook + #'ivy--minibuffer-setup + (let* ((hist (or history 'ivy-history)) + (minibuffer-completion-table collection) + (minibuffer-completion-predicate predicate) + (ivy-height (ivy--height caller)) + (resize-mini-windows (unless (display-graphic-p) + 'grow-only))) + (if (and ivy-auto-select-single-candidate + ivy--all-candidates + (null (cdr ivy--all-candidates))) + (progn + (setf (ivy-state-current ivy-last) + (car ivy--all-candidates)) + (setq ivy-exit 'done)) + (condition-case err + (read-from-minibuffer + prompt + (ivy-state-initial-input ivy-last) + (make-composed-keymap keymap ivy-minibuffer-map) + nil + hist) + (error + (unless (equal err '(error "Selecting deleted buffer")) + (signal (car err) (cdr err)))))) + (when (eq ivy-exit 'done) + (ivy--update-history hist)))) + (let ((session (or (plist-get extra-props :session) + (unless (or (minibufferp) + (null (ivy-state-action ivy-last)) + (eq (ivy--get-action ivy-last) #'identity)) + caller)))) + (when session + (setf (ivy-state-extra-props ivy-last) + (plist-put extra-props :ivy-data `(:all-candidates ,ivy--all-candidates + :text ,ivy-text))) + (ivy--alist-set 'ivy--sessions session ivy-last))) + (ivy--cleanup)) + (ivy-call))) + +(defun ivy--update-history (hist) + (unless (eq hist t) + (let ((item + (if (or (string= ivy-text "") + (eq (plist-get (ivy-state-extra-props ivy-last) :caller) + #'ivy-completing-read) + (eq (ivy-state-history ivy-last) 'file-name-history)) + (ivy-state-current ivy-last) + ivy-text))) + (cond ((equal item "")) + ((stringp item) + (let ((history-delete-duplicates t)) + (add-to-history + hist (propertize item 'ivy-index ivy--index)))))))) + +(defun ivy--cleanup () + ;; Fixes a bug in ESS, #1660 + (put 'post-command-hook 'permanent-local nil) + (remove-hook 'post-command-hook #'ivy--queue-exhibit) + (remove-hook 'window-size-change-functions #'ivy--window-size-changed) + (let ((cleanup (ivy--display-function-prop :cleanup)) + (unwind (ivy-state-unwind ivy-last))) + (when (functionp cleanup) + (funcall cleanup)) + (when unwind + (funcall unwind))) + (ivy--pulse-cleanup) + (unless (eq ivy-exit 'done) + (ivy-recursive-restore))) + +(defun ivy--display-function-prop (prop) + "Return PROP associated with current `ivy--display-function'." + (plist-get (cdr (assq ivy--display-function + ivy-display-functions-props)) + prop)) + +(defvar Info-complete-menu-buffer) + +(defun ivy--alist-to-cands (alist) + "Transform ALIST to a list of strings." + (let ((i -1)) + (mapcar (lambda (x) + (propertize x 'idx (cl-incf i))) + (all-completions "" alist)))) + +(defvar ivy--minibuffer-metadata nil + "Store `completion-metadata'.") + +(defun ivy--reset-state (state) + "Reset the ivy to STATE. +This is useful for recursive `ivy-read'." + (setq ivy-marked-candidates nil) + (setq ivy--minibuffer-metadata nil) + (unless (equal (selected-frame) (ivy-state-frame state)) + (select-window (active-minibuffer-window))) + (let* ((prompt (or (ivy-state-prompt state) "")) + (collection (ivy-state-collection state)) + (predicate (ivy-state-predicate state)) + (history (ivy-state-history state)) + (preselect (ivy-state-preselect state)) + (re-builder (ivy-state-re-builder state)) + (dynamic-collection (ivy-state-dynamic-collection state)) + (require-match (ivy-state-require-match state)) + (caller (or (ivy-state-caller state) this-command)) + (sort (or (ivy-state-sort state) (assoc caller ivy-sort-functions-alist))) + (initial-input + (or (ivy-state-initial-input state) + (let ((init (ivy-alist-setting ivy-initial-inputs-alist caller))) + (if (functionp init) (funcall init) init)))) + (def (ivy-state-def state))) + (when (and (eq caller 'swiper-isearch) (buffer-modified-p)) + (setq preselect nil)) + (setq ivy--extra-candidates (ivy--compute-extra-candidates caller)) + (setq ivy--directory nil) + (setq ivy--directory-hist (list default-directory)) + (setq ivy-case-fold-search ivy-case-fold-search-default) + (setf (ivy-state-re-builder ivy-last) + (setq ivy--regex-function + (or re-builder + (and (functionp collection) + (cdr (assq collection ivy-re-builders-alist))) + (ivy-alist-setting ivy-re-builders-alist) + #'ivy--regex))) + (setq ivy--subexps 0) + (setq ivy--regexp-quote #'regexp-quote) + (setq ivy--old-text "") + (setq ivy--full-length nil) + (ivy-set-text (or initial-input "")) + (setq ivy--index 0) + (setq ivy-calling nil) + (setq ivy-use-ignore ivy-use-ignore-default) + (setf (ivy-state-ignore state) ivy-use-ignore) + (setq ivy--highlight-function + (or (cdr (assq (ivy-alist-setting ivy-re-builders-alist) + ivy-highlight-functions-alist)) + #'ivy--highlight-default)) + (let ((ivy-recursive-restore nil) + coll sort-fn) + (cond ((eq collection #'Info-read-node-name-1) + (setq coll + (if (equal (bound-and-true-p Info-current-file) "dir") + (mapcar (lambda (x) (format "(%s)" x)) + (delete-dups + (all-completions "(" collection predicate))) + (all-completions "" collection predicate)))) + ((memq collection '(read-file-name-internal ffap-read-file-or-url-internal)) + (require 'tramp) + (when (and (equal def initial-input) + (member "./" ivy-extra-directories)) + (setq def nil)) + (setq ivy--directory default-directory) + (when (and initial-input + (not (equal initial-input ""))) + (cond ((file-directory-p initial-input) + (when (equal (file-name-nondirectory initial-input) "") + (setf (ivy-state-preselect state) (setq preselect nil)) + (setq def nil)) + (setq ivy--directory (file-name-as-directory initial-input)) + (setq initial-input nil) + (when preselect + (let ((preselect-directory + (file-name-directory preselect))) + (when (and preselect-directory + (not (equal + (expand-file-name + preselect-directory) + (expand-file-name ivy--directory)))) + (setf (ivy-state-preselect state) + (setq preselect nil)))))) + ((ignore-errors + (file-exists-p (file-name-directory initial-input))) + (setq ivy--directory (file-name-directory initial-input)) + (setf (ivy-state-preselect state) + (file-name-nondirectory initial-input))))) + (require 'dired) + (when preselect + (let ((preselect-directory (ivy--parent-dir preselect))) + (when (and preselect-directory + (not (string= preselect-directory + default-directory))) + (setq ivy--directory preselect-directory)) + (setq preselect (file-relative-name preselect + preselect-directory)) + (setf (ivy-state-preselect state) preselect))) + (setq sort nil) + (setq coll (ivy--sorted-files ivy--directory)) + (when initial-input + (unless (or require-match + (equal initial-input default-directory) + (equal initial-input "")) + (setq coll (cons initial-input coll))) + (setq initial-input (file-name-nondirectory initial-input)))) + ((eq collection #'internal-complete-buffer) + (setq coll (ivy--buffer-list + "" + (and ivy-use-virtual-buffers + (member caller '(ivy-switch-buffer + ivy-switch-buffer-other-window + counsel-switch-buffer))) + predicate))) + (dynamic-collection + (setq ivy--minibuffer-metadata + (ignore-errors + (completion-metadata + "" + (ivy-state-collection ivy-last) + (ivy-state-predicate ivy-last)))) + (setq coll (if (and (eq this-command 'ivy-resume) (not (buffer-modified-p))) + ivy--all-candidates + (ivy--dynamic-collection-cands (or initial-input ""))))) + ((consp (car-safe collection)) + (setq collection (cl-remove-if-not predicate collection)) + (when (and sort (setq sort-fn (ivy--sort-function caller))) + (setq collection (sort (copy-sequence collection) sort-fn)) + (setq sort nil)) + (setf (ivy-state-collection ivy-last) collection) + (setq coll (ivy--alist-to-cands collection))) + ((or (functionp collection) + (byte-code-function-p collection) + (vectorp collection) + (hash-table-p collection) + (and (listp collection) (symbolp (car collection)))) + (let ((Info-complete-menu-buffer + ;; FIXME: This is a temporary workaround for issue #1803. + (or (bound-and-true-p Info-complete-menu-buffer) + (ivy-state-buffer state)))) + (setq coll (all-completions "" collection predicate)))) + (t + (setq coll (all-completions "" collection predicate)))) + (unless (ivy-state-dynamic-collection ivy-last) + (setq coll (delete "" coll))) + (when (and sort + (or (functionp collection) + (not (eq history 'org-refile-history))) + (setq sort-fn (ivy--sort-function + (if (functionp collection) collection caller))) + (listp coll) + (null (nthcdr ivy-sort-max-size coll))) + (setq coll (sort (copy-sequence coll) sort-fn))) + (when def + (cond ((stringp (car-safe def)) + (setq coll + (delete-dups + (append def coll)))) + ((and (stringp def) (not (member def coll))) + (push def coll)))) + (setq coll (ivy--set-candidates coll)) + (setq ivy--old-re nil) + (setq ivy--old-cands nil) + (when initial-input + ;; Needed for anchor to work + (setq ivy--old-cands coll) + (setq ivy--old-cands (ivy--filter initial-input coll))) + (unless (setq ivy--trying-to-resume-dynamic-collection + (and preselect dynamic-collection)) + (when (integerp preselect) + (setq ivy--old-re "") + (ivy-set-index preselect))) + (setq ivy--all-candidates coll) + (unless (integerp preselect) + (ivy-set-index (or + (and dynamic-collection + ivy--index) + (and preselect + (ivy--preselect-index + preselect + (if initial-input + ivy--old-cands + coll))) + 0)))) + (setq ivy-exit nil) + (setq ivy--default + (if (region-active-p) + (buffer-substring (region-beginning) (region-end)) + (ivy-thing-at-point))) + (setq ivy--prompt (ivy-add-prompt-count (ivy--quote-format-string prompt))) + (setq ivy--use-selectable-prompt (ivy--prompt-selectable-p)) + (setf (ivy-state-initial-input ivy-last) initial-input))) + +(defun ivy-add-prompt-count (prompt) + "Add count information to PROMPT." + (cond ((null ivy-count-format) + (error "`ivy-count-format' must not be nil; set it to \"\" instead")) + ((string-match "%d.*\\(%d\\)" ivy-count-format) + (let* ((w + (if (listp ivy--all-candidates) + (1+ (floor (log (max 1 (length ivy--all-candidates)) 10))) + 1)) + (s (replace-match (format "%%-%dd" w) t t ivy-count-format 1))) + (string-match "%d" s) + (concat (replace-match (format "%%%dd" w) t t s) + prompt))) + ((string-match-p "%.*d" ivy-count-format) + (concat ivy-count-format prompt)) + (t + prompt))) + +(defun ivy--quote-format-string (str) + "Make STR suitable for `format' with no extra arguments." + (ivy--string-replace "%" "%%" str)) + +;;;###autoload +(defun ivy-completing-read (prompt collection + &optional predicate require-match initial-input + history def inherit-input-method) + "Read a string in the minibuffer, with completion. + +This interface conforms to `completing-read' and can be used for +`completing-read-function'. + +PROMPT is a string that normally ends in a colon and a space. +COLLECTION is either a list of strings, an alist, an obarray, or a hash table. +PREDICATE limits completion to a subset of COLLECTION. +REQUIRE-MATCH is a boolean value or a symbol. See `completing-read'. +INITIAL-INPUT is a string inserted into the minibuffer initially. +HISTORY is a list of previously selected inputs. +DEF is the default value. +INHERIT-INPUT-METHOD is currently ignored." + (let ((handler + (and (< ivy-completing-read-ignore-handlers-depth (minibuffer-depth)) + (assq this-command ivy-completing-read-handlers-alist)))) + (if handler + (let ((completion-in-region-function #'completion--in-region) + (ivy-completing-read-ignore-handlers-depth (1+ (minibuffer-depth)))) + (funcall (cdr handler) + prompt collection + predicate require-match + initial-input history + def inherit-input-method)) + ;; See the doc of `completing-read'. + (when (consp history) + (when (numberp (cdr history)) + (setq initial-input (nth (1- (cdr history)) + (symbol-value (car history))))) + (setq history (car history))) + (when (consp def) + (setq def (car def))) + (let ((str (ivy-read + prompt collection + :predicate predicate + :require-match (and collection require-match) + :initial-input + (cond ((consp initial-input) + (car initial-input)) + ((and (stringp initial-input) + (not (eq collection #'read-file-name-internal))) + (ivy--string-replace "+" "\\+" initial-input)) + (initial-input)) + :preselect def + :def def + :history history + :keymap nil + :dynamic-collection ivy-completing-read-dynamic-collection + :extra-props '(:caller ivy-completing-read) + :caller (if (and collection (symbolp collection)) + collection + this-command)))) + (if (string= str "") + ;; For `completing-read' compat, return the first element of + ;; DEFAULT, if it is a list; "", if DEFAULT is nil; or DEFAULT. + (or def "") + str))))) + +(defun ivy-completing-read-with-empty-string-def + (prompt collection + &optional predicate require-match initial-input + history def inherit-input-method) + "Same as `ivy-completing-read' but with different handling of DEF. + +Specifically, if DEF is nil, it is treated the same as if DEF was +the empty string. This mimics the behavior of +`completing-read-default'. This function can therefore be used in +place of `ivy-completing-read' for commands that rely on this +behavior." + (ivy-completing-read + prompt collection predicate require-match initial-input + history (or def "") inherit-input-method)) + +(declare-function mc/all-fake-cursors "ext:multiple-cursors-core") + +;; Kludge: Try to retain original minibuffer completion data. +(defvar ivy--minibuffer-table) +(defvar ivy--minibuffer-pred) +(defvar ivy--minibuffer-try nil + "Store original `try-completion' result for sole completions.") + +(defun ivy-completion-in-region-action (str) + "Insert STR, erasing the previous one. +The previous string is between `ivy-completion-beg' and `ivy-completion-end'." + (when (consp str) + (setq str (cdr str))) + (when (stringp str) + (let ((fake-cursors (and (require 'multiple-cursors-core nil t) + (mc/all-fake-cursors))) + (pt (point)) + (beg ivy-completion-beg) + (end ivy-completion-end)) + (when beg + (delete-region beg end)) + (setq ivy-completion-beg (point)) + (insert (substring-no-properties str)) + (let ((minibuffer-completion-table (if (boundp 'ivy--minibuffer-table) + ivy--minibuffer-table + (ivy-state-collection ivy-last))) + (minibuffer-completion-predicate (if (boundp 'ivy--minibuffer-pred) + ivy--minibuffer-pred + (ivy-state-predicate ivy-last))) + (newstr (or (car-safe ivy--minibuffer-try) str))) + (completion--done newstr (cond ((eq ivy--minibuffer-try t) 'finished) + ((eq ivy-exit 'done) 'unknown) + ('exact)))) + (setq ivy-completion-end (point)) + (save-excursion + (dolist (cursor fake-cursors) + (goto-char (overlay-start cursor)) + (delete-region (+ (point) (- beg pt)) + (+ (point) (- end pt))) + (insert (substring-no-properties str)) + ;; manually move the fake cursor + (move-overlay cursor (point) (1+ (point))) + (set-marker (overlay-get cursor 'point) (point)) + (set-marker (overlay-get cursor 'mark) (point))))))) + +(defalias 'ivy--face-list-p + (if (fboundp 'face-list-p) + #'face-list-p + (lambda (face) + (and (listp face) + (listp (cdr face)) + (not (keywordp (car face)))))) + "Compatibility shim for Emacs 25 `face-list-p'.") + +;; FIXME: Should this return the smallest such index instead? +;; Usually the two are equal, but perhaps there exist more +;; exotic applications of `completions-first-difference'. +;; +;; Completing files under a directory foo/ can have a first difference at +;; index 0 in some Emacs versions, and no such property in other versions. +;; So perhaps this function should return 0 instead of (length str) when no +;; property is found? That still follows the 'largest index' definition. +(defun ivy-completion-common-length (str) + "Return the length of the completion-matching prefix of STR. + +That is, return the largest index into STR at which either the +`face' or `font-lock-face' property value contains the face +`completions-first-difference'. +If no such index is found, return the length of STR. + +Typically the completion-matching parts of STR have previously been +propertized by `completion-all-completions', but then the base-size +returned by that function should be preferred over +`ivy-completion-common-length'." + (declare (obsolete "it is no longer used." "0.15.1")) + (let* ((char-property-alias-alist '((face font-lock-face))) + (cmn (length str)) + (i cmn)) + (when (> i 0) + (while (if (let ((face (get-text-property (1- i) 'face str))) + (or (eq 'completions-first-difference face) + (and (ivy--face-list-p face) + (memq 'completions-first-difference face)))) + (ignore (setq cmn (1- i))) + (setq i (previous-single-property-change i 'face str))))) + cmn)) + +(defun ivy-completion-in-region (start end collection &optional predicate) + "An Ivy function suitable for `completion-in-region-function'. +The function completes the text between START and END using COLLECTION. +PREDICATE (a function called with no arguments) says when to exit. +See `completion-in-region' for further information." + (let* ((enable-recursive-minibuffers t) + (reg (- end start)) + (str (buffer-substring-no-properties start end)) + (completion-ignore-case (ivy--case-fold-p str)) + (md (completion-metadata str collection predicate)) + (try (completion-try-completion str collection predicate reg md)) + (comps (completion-all-completions str collection predicate reg md)) + (last (last comps)) + (base-size (or (cdr last) 0)) + (ivy--minibuffer-table collection) + (ivy--minibuffer-pred predicate)) + (when last (setcdr last ())) + ;; For no/sole match: + ;; give priority to boolean `try', falling back on `comps'. + (cond ((not (and try (or (eq try t) comps))) + (and (not completion-fail-discreetly) + completion-show-inline-help + (minibuffer-message "No matches")) + nil) + ((and try (or (eq try t) (equal (list str) comps))) + (goto-char end) + (let ((minibuffer-completion-table collection) + (minibuffer-completion-predicate predicate)) + (completion--done str 'finished "Sole match")) + t) + (t + (when (eq collection 'crm--collection-fn) + (setq comps (delete-dups comps))) + (let ((initial (substring str base-size)) + (base-pos (+ start base-size))) + (delete-region base-pos end) + (setq ivy-completion-beg base-pos) + (setq ivy-completion-end ivy-completion-beg) + (if (null (cdr comps)) + (let ((ivy--minibuffer-try try)) + (unless (minibuffer-window-active-p (selected-window)) + (setf (ivy-state-window ivy-last) (selected-window))) + (ivy-completion-in-region-action + (substring-no-properties (car comps)))) + (dolist (s comps) + ;; Remove face `completions-first-difference'. + (ivy--remove-props s 'face)) + (setq ivy--old-re nil) + (unless (ivy--filter initial comps) + (setq initial nil) + (setq predicate nil) + (setq collection comps)) + (unless (derived-mode-p #'emacs-lisp-mode) + (setq collection comps) + (setq predicate nil)) + (ivy-read (format "(%s): " str) collection + :predicate predicate + ;; FIXME: The anchor is intrusive and not easily + ;; configurable by `ivy-initial-inputs-alist' or + ;; `ivy-hooks-alist'. + :initial-input (concat + (and (derived-mode-p #'emacs-lisp-mode) + "^") + initial) + :action #'ivy-completion-in-region-action + :unwind (lambda () + (unless (eq ivy-exit 'done) + (goto-char ivy-completion-beg) + (when initial + (insert initial)))) + :caller 'ivy-completion-in-region))) + ;; Return value should be t on valid completion; + ;; see `completion-in-region'. + t)))) + +(defun ivy-completion-in-region-prompt () + "Prompt function for `ivy-completion-in-region'. +See `ivy-set-prompt'." + (and (window-minibuffer-p (ivy-state-window ivy-last)) + (ivy-add-prompt-count (ivy-state-prompt ivy-last)))) + +(ivy-set-prompt #'ivy-completion-in-region #'ivy-completion-in-region-prompt) + +(defcustom ivy-do-completion-in-region t + "When non-nil `ivy-mode' will set `completion-in-region-function'." + :type 'boolean) + +(defvar ivy--old-crf nil + "Store previous value of `completing-read-function'.") + +(defvar ivy--old-cirf nil + "Store previous value of `completion-in-region-function'.") + +;;;###autoload +(define-minor-mode ivy-mode + "Toggle Ivy mode on or off. +Turn Ivy mode on if ARG is positive, off otherwise. +Turning on Ivy mode sets `completing-read-function' to +`ivy-completing-read'. + +Global bindings: +\\{ivy-mode-map} + +Minibuffer bindings: +\\{ivy-minibuffer-map}" + :group 'ivy + :global t + :keymap ivy-mode-map + :lighter " ivy" + (if ivy-mode + (progn + (unless (eq completing-read-function #'ivy-completing-read) + (setq ivy--old-crf completing-read-function) + (setq completing-read-function #'ivy-completing-read)) + (when ivy-do-completion-in-region + (unless (eq completion-in-region-function #'ivy-completion-in-region) + (setq ivy--old-cirf completion-in-region-function) + (setq completion-in-region-function #'ivy-completion-in-region)))) + (when (eq completing-read-function #'ivy-completing-read) + (setq completing-read-function (or ivy--old-crf + #'completing-read-default)) + (setq ivy--old-crf nil)) + (when (eq completion-in-region-function #'ivy-completion-in-region) + (setq completion-in-region-function (or ivy--old-cirf + #'completion--in-region)) + (setq ivy--old-cirf nil)))) + +(defun ivy--preselect-index (preselect candidates) + "Return the index of PRESELECT in CANDIDATES." + (or (cond ((integerp preselect) + (if (integerp (car candidates)) + (cl-position preselect candidates) + preselect)) + ((cl-position preselect candidates :test #'equal)) + ((ivy--regex-p preselect) + (cl-position preselect candidates :test #'string-match-p))) + 0)) + +;;; Implementation +;;;; Regexp + +(defun ivy-re-match (re-seq str) + "Return non-nil if RE-SEQ is matched by STR. + +RE-SEQ is a list of (RE . MATCH-P). + +RE is a regular expression. + +MATCH-P is t when RE should match STR and nil when RE should not +match STR. + +Each element of RE-SEQ must match for the function to return true. + +This concept is used to generalize regular expressions for +`ivy--regex-plus' and `ivy--regex-ignore-order'." + (let ((res t)) + (while (let ((pair (pop re-seq))) + (and pair (setq res (xor (not (cdr pair)) + (string-match-p (car pair) str)))))) + res)) + +(defvar ivy--regex-hash + (make-hash-table :test #'equal) + "Store pre-computed regex.") + +(defvar ivy--input-garbage nil) + +(defun ivy--split (str) + "Split STR into list of substrings bounded by spaces. +Single spaces act as splitting points. Consecutive spaces +\"quote\" their preceding spaces, i.e., guard them from being +split. This allows the literal interpretation of N spaces by +inputting N+1 spaces. Any substring not constituting a valid +regexp is passed to `regexp-quote'." + (let ((len (length str)) + (i 0) + (start 0) + (res nil) + match-len + end + c) + (catch 'break + (while (< i len) + (setq c (aref str i)) + (cond ((= ?\[ c) + (if (setq end (ivy--match-regex-brackets + (substring str i))) + (cl-incf i end) + (setq ivy--input-garbage (substring str i)) + (throw 'break nil))) + ((= ?\\ c) + (if (and (< (1+ i) len) (= ?\( (aref str (1+ i)))) + (progn + (when (> i start) + (push (substring str start i) res)) + (if (eq (string-match "\\\\([^\0]*?\\\\)" str i) i) + (progn + (push (match-string 0 str) res) + (setq i (match-end 0)) + (setq start i)) + (setq ivy--input-garbage (substring str i)) + (throw 'break nil))) + (cl-incf i))) + ((= ?\s c) + (string-match " +" str i) + (setq match-len (- (match-end 0) (match-beginning 0))) + (if (= match-len 1) + (progn + (when (> i start) + (push (substring str start i) res)) + (setq start (1+ i))) + (setq str (replace-match + (make-string (1- match-len) ?\s) + nil nil str)) + (setq len (length str)) + (cl-incf i (1- match-len))) + (cl-incf i)) + (t + (cl-incf i))))) + (when (< start i) + (push (substring str start) res)) + (mapcar #'ivy--regex-or-literal (nreverse res)))) + +(defun ivy--match-regex-brackets (str) + (let ((len (length str)) + (i 1) + (open-count 1) + c) + (while (and (< i len) + (> open-count 0)) + (setq c (aref str i)) + (cond ((= c ?\[) + (cl-incf open-count)) + ((= c ?\]) + (cl-decf open-count))) + (cl-incf i)) + (when (= open-count 0) + (if (eq (string-match "[+*?]" str i) i) + (match-end 0) + i)))) + +(defun ivy--trim-trailing-re (regex) + "Trim incomplete REGEX. +If REGEX ends with \\|, trim it, since then it matches an empty string." + (if (string-match "\\`\\(.*\\)[\\]|\\'" regex) + (match-string 1 regex) + regex)) + +(defun ivy--regex (str &optional greedy) + "Re-build regex pattern from STR in case it has a space. +When GREEDY is non-nil, join words in a greedy way." + (let ((hashed (unless greedy + (gethash str ivy--regex-hash)))) + (if hashed + (progn + (setq ivy--subexps (car hashed)) + (cdr hashed)) + (when (string-match-p "\\(?:[^\\]\\|^\\)\\\\\\'" str) + (setq str (substring str 0 -1))) + (setq str (ivy--trim-trailing-re str)) + (cdr (puthash str + (let ((subs (ivy--split str))) + (if (= (length subs) 1) + (cons + (setq ivy--subexps 0) + (if (string-match-p "\\`\\.[^.]" (car subs)) + (concat "\\." (substring (car subs) 1)) + (car subs))) + (cons + (setq ivy--subexps (length subs)) + (replace-regexp-in-string + "\\.\\*\\??\\\\( " + "\\( " + (mapconcat + (lambda (x) + (if (string-match-p "\\`\\\\([^?][^\0]*\\\\)\\'" x) + x + (format "\\(%s\\)" x))) + subs + (if greedy ".*" ".*?")) + t t)))) + ivy--regex-hash))))) + +(defun ivy--regex-p (object) + "Return OBJECT if it is a valid regular expression, else nil." + (ignore-errors (ignore (string-match-p object "")) object)) + +(defun ivy--regex-or-literal (str) + "If STR isn't a legal regexp, escape it." + (or (ivy--regex-p str) (regexp-quote str))) + +(defun ivy--split-negation (str) + "Split STR into text before and after ! delimiter. +Do not split if the delimiter is escaped as \\!. + +Assumes there is at most one un-escaped delimiter and discards +text after delimiter if it is empty. Modifies match data." + (unless (string= str "") + (mapcar (lambda (split) + ;; Store "\!" as "!". + (ivy--string-replace "\\!" "!" split)) + (let ((delim "\\(?:\\`\\|[^\\]\\)\\(!\\)")) + (if (string-match delim str) + ;; Ignore everything past first un-escaped ! rather than + ;; crashing. We can't warn or error because the minibuffer is + ;; already active. + (let* ((i (match-beginning 1)) + (j (and (string-match delim str (1+ i)) + (match-beginning 1))) + (neg (substring str (1+ i) j))) + (cons (substring str 0 i) + (and (not (string= neg "")) + (list neg)))) + (list str)))))) + +(defun ivy--split-spaces (str) + "Split STR on spaces, unless they're preceded by \\. +No un-escaped spaces are left in the output. Any substring not +constituting a valid regexp is passed to `regexp-quote'." + (when str + (let ((i 0) ; End of last search. + (j 0) ; End of last delimiter. + parts) + (while (string-match "\\(\\\\ \\)\\| +" str i) + (setq i (match-end 0)) + (if (not (match-beginning 1)) + ;; Un-escaped space(s). + (let ((delim (match-beginning 0))) + (when (< j delim) + (push (substring str j delim) parts)) + (setq j i)) + ;; Store "\ " as " ". + (setq str (replace-match " " t t str 1)) + (setq i (1- i)))) + (when (< j (length str)) + (push (substring str j) parts)) + (mapcar #'ivy--regex-or-literal (nreverse parts))))) + +(defun ivy--regex-ignore-order (str) + "Re-build regex from STR by splitting at spaces and using ! for negation. + +Examples: +foo -> matches \"foo\" +foo bar -> matches if both \"foo\" and \"bar\" match (any order) +foo !bar -> matches if \"foo\" matches and \"bar\" does not match +foo !bar baz -> matches if \"foo\" matches and neither \"bar\" nor \"baz\" match +foo[a-z] -> matches \"foo[a-z]\" + +Escaping examples: +foo\\!bar -> matches \"foo!bar\" +foo\\ bar -> matches \"foo bar\" + +Returns a list suitable for `ivy-re-match'." + (setq str (ivy--trim-trailing-re str)) + (let* (regex-parts + (raw-parts (ivy--split-negation str))) + (dolist (part (ivy--split-spaces (car raw-parts))) + (push (cons part t) regex-parts)) + (when (cdr raw-parts) + (dolist (part (ivy--split-spaces (cadr raw-parts))) + (push (cons part nil) regex-parts))) + (if regex-parts (nreverse regex-parts) + ""))) + +(defun ivy--regex-plus (str) + "Build a regex sequence from STR. +Spaces are wild card characters, everything before \"!\" should +match. Everything after \"!\" should not match." + (let ((parts (ivy--split-negation str))) + (cl-case (length parts) + (0 + "") + (1 + (if (= (aref str 0) ?!) + (list (cons "" t) + (list (ivy--regex (car parts)))) + (ivy--regex (car parts)))) + (2 + (cons + (cons (ivy--regex (car parts)) t) + (mapcar #'list (split-string (cadr parts) " " t)))) + (t (error "Unexpected: use only one !"))))) + +(defun ivy--regex-fuzzy (str) + "Build a regex sequence from STR. +Insert .* between each char." + (setq str (ivy--trim-trailing-re str)) + (if (string-match "\\`\\(\\^?\\)\\(.*?\\)\\(\\$?\\)\\'" str) + (prog1 + (concat (match-string 1 str) + (let ((lst (string-to-list (match-string 2 str)))) + (apply #'concat + (cl-mapcar + #'concat + (cons "" (cdr (mapcar (lambda (c) (format "[^%c\n]*" c)) + lst))) + (mapcar (lambda (x) (format "\\(%s\\)" (regexp-quote (char-to-string x)))) + lst)))) + (match-string 3 str)) + (setq ivy--subexps (length (match-string 2 str)))) + str)) + +(defcustom ivy-fixed-height-minibuffer nil + "When non nil, fix the height of the minibuffer during ivy completion. +This effectively sets the minimum height at this level to `ivy-height' and +tries to ensure that it does not change depending on the number of candidates." + :type 'boolean) + +;;;; Rest + +(defcustom ivy-truncate-lines t + "Minibuffer setting for `truncate-lines'." + :type 'boolean) + +(defun ivy--minibuffer-setup () + "Setup ivy completion in the minibuffer." + ;; Guard for --without-x builds where `mwheel' is not preloaded. + (when (boundp 'mwheel-scroll-up-function) + (setq-local mwheel-scroll-up-function 'ivy-next-line)) + (when (boundp 'mwheel-scroll-down-function) + (setq-local mwheel-scroll-down-function 'ivy-previous-line)) + (setq-local completion-show-inline-help nil) + (setq-local line-spacing nil) + (setq-local minibuffer-default-add-function + (lambda () + (list ivy--default))) + (setq-local inhibit-field-text-motion nil) + (setq truncate-lines ivy-truncate-lines) + (setq-local max-mini-window-height ivy-height) + (let ((height (cond ((and ivy-fixed-height-minibuffer + (not (eq (ivy-state-caller ivy-last) + #'ivy-completion-in-region))) + (+ ivy-height (if ivy-add-newline-after-prompt 1 0))) + (ivy-add-newline-after-prompt 2)))) + (when height + (set-window-text-height nil height))) + (add-hook 'post-command-hook #'ivy--queue-exhibit nil t) + (add-hook 'window-size-change-functions #'ivy--window-size-changed nil t) + (let ((hook (ivy-alist-setting ivy-hooks-alist))) + (when (functionp hook) + (funcall hook)))) + +(defun ivy--input () + "Return the current minibuffer input." + ;; assume one-line minibuffer input + (save-excursion + (goto-char (minibuffer-prompt-end)) + (let ((inhibit-field-text-motion t)) + (buffer-substring-no-properties + (point) + (line-end-position))))) + +(defun ivy--minibuffer-cleanup () + "Delete the displayed completion candidates." + (save-excursion + (goto-char (minibuffer-prompt-end)) + (delete-region (line-end-position) (point-max)))) + +(defun ivy-cleanup-string (str) + "Destructively remove unwanted text properties from STR." + (ivy--remove-props str 'field)) + +(defvar ivy-set-prompt-text-properties-function + #'ivy-set-prompt-text-properties-default + "Function to set the text properties of the default ivy prompt. +Called with two arguments, PROMPT and PROPS, where PROMPT is the +string to be propertized and PROPS is a plist of default text +properties that may be applied to PROMPT. The function should +return the propertized PROMPT, which may be modified in-place.") + +(defun ivy-set-prompt-text-properties-default (prompt props) + "Propertize (confirm) and (match required) parts of PROMPT. +PROPS is a plist of default text properties to apply to these +parts beyond their respective faces `ivy-confirm-face' and +`ivy-match-required-face'." + (dolist (pair '(("confirm" . ivy-confirm-face) + ("match required" . ivy-match-required-face))) + (let* ((beg (ivy--string-search (car pair) prompt)) + (end (and beg (+ beg (length (car pair)))))) + (when beg + (add-face-text-property beg end (cdr pair) nil prompt) + (add-text-properties beg end props prompt)))) + prompt) + +(defun ivy-prompt () + "Return the current prompt." + (let* ((caller (ivy-state-caller ivy-last)) + (fn (plist-get ivy--prompts-list caller))) + (if fn + (condition-case err + (funcall fn) + (wrong-number-of-arguments + (lwarn 'ivy :error "%s + Prompt function set via `ivy-set-prompt' for caller `%s' + should take no arguments." + (error-message-string err) + caller) + ;; Old behavior. + (funcall fn (ivy-state-prompt ivy-last)))) + ivy--prompt))) + +(defun ivy--break-lines (str width) + "Break each line in STR with newlines to fit into WIDTH columns." + (if (<= width 0) + str + (let (lines) + (dolist (line (split-string str "\n")) + (while (and line (> (string-width line) width)) + (let ((prefix "") (extra 0)) + (while (string-empty-p prefix) + ;; Grow `width' until it fits at least one char from `line'. + (setq prefix (truncate-string-to-width line (+ width extra))) + (setq extra (1+ extra))) + ;; Avoid introducing spurious newline if `prefix' and `line' are + ;; equal, i.e., if `line' couldn't be truncated to `width'. + (setq line (and (> (length line) (length prefix)) + (substring line (length prefix)))) + (push prefix lines))) + (when line (push line lines))) + (string-join (nreverse lines) "\n")))) + +(defun ivy--propertize-prompt (prompt) + "Propertize PROMPT like `read-from-minibuffer' would. +Also handle `ivy-set-prompt-text-properties-function'." + (let ((len (length prompt)) + ;; Added unconditionally by `read-from-minibuffer'. + (props (list 'front-sticky t 'rear-nonsticky t 'field t)) + ;; Configurable. + (extras minibuffer-prompt-properties)) + ;; Filter out `face'; it is documented as being appended instead, and was + ;; historically excluded from `ivy-set-prompt-text-properties-function'. + (while extras + (let ((key (pop extras)) + (val (pop extras))) + (if (eq key 'face) + (add-face-text-property 0 len val t prompt) + (setq props (plist-put props key val))))) + (add-text-properties 0 len props prompt) + (funcall ivy-set-prompt-text-properties-function prompt props))) + +(defun ivy--insert-prompt () + "Update the prompt according to `ivy--prompt'." + (when (setq ivy--prompt (ivy-prompt)) + (unless (memq this-command '(ivy-done ivy-alt-done ivy-partial-or-done + counsel-find-symbol)) + (setq ivy--prompt-extra "")) + (let (head tail) + (if (string-match "\\(.*?\\)\\(:? ?\\)\\'" ivy--prompt) + (progn + (setq head (match-string 1 ivy--prompt)) + (setq tail (match-string 2 ivy--prompt))) + (setq head ivy--prompt) + (setq tail "")) + (let ((inhibit-read-only t) + (n-str + (concat + (and (bound-and-true-p minibuffer-depth-indicate-mode) + (> (minibuffer-depth) 1) + (format "[%d] " (minibuffer-depth))) + (let ((count (or (and (ivy-state-dynamic-collection ivy-last) + ivy--full-length) + ivy--length))) + (if (string-match-p "%d.*%d" ivy-count-format) + (format head (min (1+ ivy--index) count) count) + (format head count))) + ivy--prompt-extra + tail)) + (d-str (if ivy--directory + (abbreviate-file-name ivy--directory) + ""))) + (save-excursion + (goto-char (point-min)) + (delete-region (point-min) (minibuffer-prompt-end)) + (let ((wid-n (string-width n-str)) + (wid-d (string-width d-str)) + (ww (window-width))) + (setq n-str + (cond ((> (+ wid-n wid-d) ww) + (concat n-str "\n" d-str "\n")) + ((> (+ wid-n wid-d (string-width ivy-text)) ww) + (concat n-str d-str "\n")) + (t + (concat n-str d-str))))) + (when ivy-pre-prompt-function + (setq n-str (concat (funcall ivy-pre-prompt-function) n-str))) + (when ivy-add-newline-after-prompt + (setq n-str (concat n-str "\n"))) + (setq n-str (ivy--break-lines n-str (window-width))) + (insert (ivy--propertize-prompt n-str))) + ;; Mark prompt as selected if the user moves there or it is the only + ;; option left. Since the user input stays put, we have to manually + ;; remove the face as well. + (when ivy--use-selectable-prompt + (if (= ivy--index -1) + (add-face-text-property + (minibuffer-prompt-end) (line-end-position) 'ivy-prompt-match) + (remove-list-of-text-properties + (minibuffer-prompt-end) (line-end-position) '(face)))) + ;; get out of the prompt area + (constrain-to-field nil (point-max)))))) + +(defun ivy--sort-maybe (collection) + "Sort COLLECTION if needed." + (let ((sort (ivy-state-sort ivy-last))) + (if (and sort + (or (functionp sort) + (functionp (setq sort (ivy--sort-function + (ivy-state-collection ivy-last)))))) + (sort (copy-sequence collection) sort) + collection))) + +(defcustom ivy-magic-slash-non-match-action + 'ivy-magic-slash-non-match-cd-selected + "Action to take when a slash is appended to a nonexistent directory. +Possible choices are `ivy-magic-slash-non-match-cd-selected', +`ivy-magic-slash-non-match-create', or nil" + :type '(choice + (const :tag "Use currently selected directory" + ivy-magic-slash-non-match-cd-selected) + (const :tag "Create and use new directory" + ivy-magic-slash-non-match-create) + (const :tag "Do nothing" + nil))) + +(defun ivy--create-and-cd (dir) + "When completing file names, create directory DIR and move there." + (make-directory dir) + (ivy--cd dir)) + +(defun ivy--magic-file-doubleslash-directory () + "Return an appropriate directory for when two slashes are entered." + (let (remote) + (cond + ;; Windows + ;; ((string-match "\\`[[:alpha:]]:/" ivy--directory) + ;; (match-string 0 ivy--directory)) + ;; Remote root if on remote + ((setq remote (file-remote-p ivy--directory)) + (concat remote "/")) + ;; Local root + (t + "/")))) + +(defun ivy--magic-file-slash () + "Handle slash when completing file names." + (when (or (and (eq this-command #'self-insert-command) + (eolp)) + (eq this-command #'ivy-partial-or-done)) + (let ((canonical (expand-file-name ivy-text ivy--directory)) + (magic (not (string= ivy-text "/")))) + (cond ((member ivy-text ivy--all-candidates) + (ivy--cd canonical)) + ((and (eq system-type 'windows-nt) (string= ivy-text "//"))) + ((string-suffix-p "//" ivy-text) + (ivy--cd + (ivy--magic-file-doubleslash-directory))) + ((string-prefix-p "/ssh:" ivy-text) + (ivy--cd (file-name-directory ivy-text))) + ((string-match "[[:alpha:]]:/\\'" ivy-text) + (let ((drive-root (match-string 0 ivy-text))) + (when (file-exists-p drive-root) + (ivy--cd drive-root)))) + ((and magic (file-directory-p canonical)) + (ivy--cd canonical)) + ((let ((default-directory ivy--directory)) + (and (or (> ivy--index 0) + (= ivy--length 1) + magic) + (not (ivy--prompt-selected-p)) + (not (equal (ivy-state-current ivy-last) "")) + (file-directory-p (ivy-state-current ivy-last)) + (or (eq ivy-magic-slash-non-match-action + 'ivy-magic-slash-non-match-cd-selected) + (eq this-command #'ivy-partial-or-done)))) + (ivy--cd + (expand-file-name (ivy-state-current ivy-last) ivy--directory))) + ((and (eq ivy-magic-slash-non-match-action + 'ivy-magic-slash-non-match-create) + magic) + (ivy--create-and-cd canonical)))))) + +(defun ivy-magic-read-file-env () + "If reading filename, jump to environment variable location." + (interactive) + (if (and ivy--directory + (equal ivy-text "")) + (let* ((cands (cl-loop for pair in process-environment + for (var val) = (split-string pair "=" t) + if (and val (not (equal "" val))) + if (file-exists-p + (if (file-name-absolute-p val) + val + (setq val + (expand-file-name val ivy--directory)))) + collect (cons var val))) + (enable-recursive-minibuffers t) + (x (ivy-read "Env: " cands)) + (path (cdr (assoc x cands)))) + (insert (if (file-accessible-directory-p path) + (file-name-as-directory path) + path)) + (ivy--cd-maybe)) + (insert last-input-event))) + +(defun ivy-make-magic-action (caller key) + "Return a command that does the equivalent of `ivy-read-action' and KEY. +This happens only when the input is empty. +The intention is to bind the result to keys that are typically +bound to `self-insert-command'." + (let* ((alist (assoc key + (plist-get + ivy--actions-list + caller))) + (doc (format "%s (`%S')" + (nth 2 alist) + (nth 1 alist)))) + `(lambda (&optional arg) + ,doc + (interactive "p") + (if (string= "" ivy-text) + (execute-kbd-macro + (kbd ,(concat "M-o " key))) + (self-insert-command arg))))) + +(defcustom ivy-magic-tilde t + "When non-nil, ~ will move home when selecting files. +Otherwise, ~/ will move home." + :type 'boolean) + +(defcustom ivy-dynamic-exhibit-delay-ms 0 + "Delay in milliseconds before dynamic collections are refreshed." + :type 'integer) + +(defvar ivy--exhibit-timer nil + "Timer for debouncing calls to `ivy--exhibit'.") + +(defvar ivy--queue-last-input nil + "Value of `ivy--input' from last `post-command-hook'.") + +(defun ivy--queue-exhibit () + "Refresh Ivy completions display, with debouncing. +This is like `ivy--exhibit', but dynamic collections are delayed by +`ivy-dynamic-exhibit-delay-ms' to avoid issues with rapid refreshes. +Should be run via minibuffer `post-command-hook'." + (if (or (<= ivy-dynamic-exhibit-delay-ms 0) + (not (ivy-state-dynamic-collection ivy-last)) + (equal ivy--queue-last-input + (setq ivy--queue-last-input (ivy--input)))) + (ivy--exhibit) + (when ivy--exhibit-timer (cancel-timer ivy--exhibit-timer)) + (setq ivy--exhibit-timer + (run-with-timer (/ ivy-dynamic-exhibit-delay-ms 1000.0) + nil #'ivy--exhibit)))) + +(defalias 'ivy--file-local-name + (if (fboundp 'file-local-name) + #'file-local-name + (lambda (file) + (or (file-remote-p file 'localname) file))) + "Compatibility shim for `file-local-name'. +The function was added in Emacs 26.1.") + +(defun ivy--magic-tilde-directory (dir) + "Return an appropriate home for DIR for when ~ or ~/ are entered." + (file-name-as-directory + (expand-file-name + (let* ((home (expand-file-name (concat (file-remote-p dir) "~/"))) + (dir-path (ivy--file-local-name dir)) + (home-path (ivy--file-local-name home))) + (if (string= dir-path home-path) + "~" + home))))) + +(defun ivy-update-candidates (cands) + (ivy--insert-minibuffer + (ivy--format + (setq ivy--all-candidates cands)))) + +(defun ivy--exhibit () + "Insert Ivy completions display. +Should be run in the minibuffer." + (when (memq #'ivy--queue-exhibit post-command-hook) + (let ((inhibit-field-text-motion nil)) + (constrain-to-field nil (point-max))) + (ivy-set-text (ivy--input)) + (let ((new-minibuffer (ivy--update-minibuffer))) + (when new-minibuffer + (ivy--insert-minibuffer new-minibuffer))) + t)) + +(defun ivy--dynamic-collection-cands (input) + (let ((coll (condition-case nil + (funcall (ivy-state-collection ivy-last) input) + (error + (funcall (ivy-state-collection ivy-last) input nil t))))) + (if (listp coll) + (mapcar (lambda (x) (if (consp x) (car x) x)) coll) + coll))) + +(defun ivy--update-minibuffer () + (prog1 + (if (ivy-state-dynamic-collection ivy-last) + ;; while-no-input would cause annoying + ;; "Waiting for process to die...done" message interruptions + (let ((inhibit-message t) + coll in-progress) + (unless (or (equal ivy--old-text ivy-text) + (eq this-command 'ivy-resume)) + (while-no-input + (setq coll (ivy--dynamic-collection-cands ivy-text)) + (when (eq coll 0) + (setq coll nil) + (setq ivy--old-re nil) + (setq in-progress t)) + (setq ivy--all-candidates (ivy--sort-maybe coll)))) + (when (eq ivy--all-candidates 0) + (setq ivy--all-candidates nil) + (setq ivy--old-re nil) + (setq in-progress t)) + (when (or ivy--all-candidates + (not (or (get-process " *counsel*") + in-progress))) + (ivy--set-index-dynamic-collection) + (ivy--format ivy--all-candidates))) + (cond (ivy--directory + (cond ((or (string= "~/" ivy-text) + (and (string= "~" ivy-text) + ivy-magic-tilde)) + (ivy--cd (ivy--magic-tilde-directory ivy--directory))) + ((string-suffix-p "/" ivy-text) + (ivy--magic-file-slash)))) + ((eq (ivy-state-collection ivy-last) #'internal-complete-buffer) + (let ((spaced (= (string-to-char ivy-text) ?\s))) + (when (xor spaced (= (string-to-char ivy--old-text) ?\s)) + (setq ivy--all-candidates + (if spaced + (ivy--buffer-list " ") + (ivy--buffer-list "" ivy-use-virtual-buffers))) + (setq ivy--old-re nil))))) + (with-current-buffer (ivy-state-buffer ivy-last) + (ivy--format + (ivy--filter ivy-text ivy--all-candidates)))) + (setq ivy--old-text ivy-text))) + +(defun ivy-display-function-fallback (str) + (let ((buffer-undo-list t)) + (save-excursion + (forward-line 1) + (insert str)))) + +(defun ivy--insert-minibuffer (text) + "Insert TEXT into minibuffer with appropriate cleanup." + (let ((resize-mini-windows nil) + (update-fn (ivy-state-update-fn ivy-last)) + (old-mark (marker-position (mark-marker))) + (win (active-minibuffer-window)) + deactivate-mark) + (when win + (with-selected-window win + (ivy--minibuffer-cleanup) + (when update-fn + (funcall update-fn)) + (ivy--insert-prompt) + ;; Do nothing if while-no-input was aborted. + (when (stringp text) + (if ivy--display-function + (funcall ivy--display-function text) + (ivy-display-function-fallback text))) + (ivy--resize-minibuffer-to-fit) + ;; prevent region growing due to text remove/add + (when (region-active-p) + (set-mark old-mark)))))) + +(defvar ivy-auto-shrink-minibuffer nil + "When non-nil and the height < `ivy-height', auto-shrink the minibuffer.") + +(make-obsolete-variable 'ivy-auto-shrink-minibuffer + 'ivy-auto-shrink-minibuffer-alist + "0.13.2 (2020-04-28)") + +(defcustom ivy-auto-shrink-minibuffer-alist nil + "An alist to configure auto-shrinking of the minibuffer. + +Each key is a caller symbol. When the value is non-nil, and the +height < `ivy-height', auto-shrink the minibuffer." + :type '(alist + :key-type symbol + :value-type boolean)) + +(defun ivy--do-shrink-window () + (let ((h (save-excursion + (goto-char (minibuffer-prompt-end)) + (let ((inhibit-field-text-motion t)) + (line-number-at-pos))))) + (shrink-window (- + (/ (window-body-height nil t) + (frame-char-height)) + ivy--length h)))) + +(defun ivy--resize-minibuffer-to-fit () + "Resize the minibuffer window size to fit the text in the minibuffer." + (unless (or (frame-root-window-p (minibuffer-window)) + (memq this-command '(ivy-read-action + ivy-dispatching-done + ivy-dispatching-call))) + (with-selected-window (minibuffer-window) + (if (fboundp 'window-text-pixel-size) + (let ((text-height (cdr (window-text-pixel-size))) + (body-height (window-body-height nil t))) + (cond ((> text-height body-height) + ;; Note: the size increment needs to be at least + ;; frame-char-height, otherwise resizing won't do + ;; anything. + (let ((delta (max (- text-height body-height) + (frame-char-height)))) + (window-resize nil delta nil t t))) + ((and (or ivy-auto-shrink-minibuffer + (ivy-alist-setting + ivy-auto-shrink-minibuffer-alist)) + (< ivy--length ivy-height)) + (ivy--do-shrink-window)))) + (let ((text-height (count-screen-lines)) + (body-height (window-body-height))) + (when (> text-height body-height) + (window-resize nil (- text-height body-height) nil t))))))) + +(defun ivy--window-size-changed (&rest _) + "Resize ivy window to fit with current frame's size." + (when ivy-mode + (ivy--resize-minibuffer-to-fit))) + +(defun ivy--add-face (str face) + "Propertize STR with FACE." + (let ((len (length str))) + (condition-case nil + (progn + (colir-blend-face-background 0 len face str) + (let ((foreground (face-foreground face))) + (when foreground + (add-face-text-property + 0 len (list :foreground foreground) nil str)))) + (error + (ignore-errors + (font-lock-append-text-property 0 len 'face face str))))) + str) + +(declare-function flx-make-string-cache "ext:flx") +(declare-function flx-score "ext:flx") + +(defvar ivy--flx-cache nil) + +(with-eval-after-load 'flx + (setq ivy--flx-cache (flx-make-string-cache))) + +(defun ivy-toggle-case-fold () + "Toggle `case-fold-search' for Ivy operations. + +Instead of modifying `case-fold-search' directly, this command +toggles `ivy-case-fold-search', which can take on more values +than the former, between nil and either `auto' or t. See +`ivy-case-fold-search-default' for the meaning of these values. + +In any Ivy completion session, the case folding starts with +`ivy-case-fold-search-default'." + (interactive) + (setq ivy-case-fold-search + (and (not ivy-case-fold-search) + (or ivy-case-fold-search-default 'auto))) + ;; Reset cache so that the candidate list updates. + (setq ivy--old-re nil)) + +(defun ivy--re-filter (filter candidates &optional mkpred) + "Return all CANDIDATES matching FILTER, or nil on error. +FILTER is either a string or a list of (REGEXP . BOOLEAN). +The result includes those CANDIDATES which are matched by each REGEXP +whose BOOLEAN is non-nil, and not matched by any other REGEXP. +A string FILTER is equivalent to ((FILTER . t)). + +If MKPRED is non-nil, it is a function to be called on each REGEXP, +returning a unary predicate for filtering CANDIDATES which overrides +this function's default regexp matching behavior." + (if (member filter '("" ())) + candidates + (setq candidates (copy-sequence candidates)) + ;; Return nil (not candidates) on error, e.g., when we try to filter + ;; `swiper-isearch' numeric candidates with `string-match-p'. + (ignore-errors + (dolist (matcher (if (stringp filter) (list (cons filter t)) filter)) + (let* ((re (car matcher)) + (pred + (if mkpred + (funcall mkpred re) + (lambda (x) (string-match-p re x))))) + (setq candidates + (cl-delete nil candidates + (if (cdr matcher) :if-not :if) + pred)))) + candidates))) + +(defun ivy--filter (name candidates) + "Return all items that match NAME in CANDIDATES. +CANDIDATES are assumed to be static." + (let ((re (funcall ivy--regex-function name))) + (if (and + ivy--old-re + ivy--old-cands + (equal re ivy--old-re)) + ;; quick caching for "C-n", "C-p" etc. + ivy--old-cands + (let* ((re-str (ivy-re-to-str re)) + (matcher (ivy-state-matcher ivy-last)) + (case-fold-search (ivy--case-fold-p name)) + (cands (cond + (matcher + (funcall matcher re candidates)) + ((and ivy--old-re + (stringp re) + (stringp ivy--old-re) + (not (ivy--string-search "\\" ivy--old-re)) + (not (equal ivy--old-re "")) + (memq (ivy--string-search + (string-remove-suffix "\\)" ivy--old-re) + re) + '(0 2)) + ivy--old-cands + (ivy--re-filter re ivy--old-cands))) + (t + (ivy--re-filter re candidates))))) + (if (memq (cdr (assq (ivy-state-caller ivy-last) + ivy-index-functions-alist)) + '(ivy-recompute-index-swiper + ivy-recompute-index-swiper-async + ivy-recompute-index-swiper-async-backward + ivy-recompute-index-swiper-backward)) + (progn + (ivy--recompute-index re-str cands) + (setq ivy--old-cands (ivy--sort name cands))) + (setq ivy--old-cands (ivy--sort name cands)) + (ivy--recompute-index re-str ivy--old-cands)) + (setq ivy--old-re re) + ivy--old-cands)))) + +(defun ivy--set-candidates (x) + "Update `ivy--all-candidates' with X." + (let (res + ;; (ivy--recompute-index-inhibit t) + ) + (dolist (source ivy--extra-candidates) + (if (equal source '(original-source)) + (if (null res) + (setq res x) + (setq res (append x res))) + (setq ivy--old-re nil) + (setq res (append + (ivy--filter ivy-text (cadr source)) + res)))) + (setq ivy--all-candidates + (if (cdr ivy--extra-candidates) + (delete-dups res) + res)))) + +(eval-and-compile + (defconst ivy--new-sort-p + (condition-case nil + (with-no-warnings (sort [])) + (wrong-number-of-arguments)) + "Whether Emacs 30 `sort' calling convention is available.")) + +(defun ivy--shorter-matches-first (_name cands) + "Sort CANDS according to their length." + (if (nthcdr ivy-sort-max-size cands) + cands + (static-if (bound-and-true-p ivy--new-sort-p) + (sort cands :key #'length) + (cl-sort (copy-sequence cands) #'< :key #'length)))) + +(defcustom ivy-sort-matches-functions-alist + '((t . nil) + (ivy-completion-in-region . ivy--shorter-matches-first) + (ivy-switch-buffer . ivy-sort-function-buffer)) + "An alist of functions for sorting matching candidates. + +Unlike `ivy-sort-functions-alist', which is used to sort the +whole collection only once, this alist of functions are used to +sort only matching candidates after each change in input. + +The alist KEY is either a collection function or t to match +previously unmatched collection functions. + +The alist VAL is a sorting function with the signature of +`ivy--prefix-sort'." + :type '(alist + :key-type (choice + (const :tag "Fall-through" t) + (symbol :tag "Collection")) + :value-type + (choice + (const :tag "Don't sort" nil) + (const :tag "Put prefix matches ahead" ivy--prefix-sort) + (function :tag "Custom sort function")))) + +(defun ivy--sort-files-by-date (_name candidates) + "Re-sort CANDIDATES according to file modification date." + (let ((default-directory ivy--directory)) + (sort (copy-sequence candidates) #'file-newer-than-file-p))) + +(defvar ivy--flx-available-p) +(defun ivy--flx-available-p () + "Try to load package `flx' once; return non-nil on success." + (if (boundp 'ivy--flx-available-p) + ivy--flx-available-p + (setq ivy--flx-available-p (require 'flx nil t)))) + +(defun ivy--sort (name candidates) + "Re-sort candidates by NAME. +All CANDIDATES are assumed to match NAME." + (let (fun) + (cond ((setq fun (ivy-alist-setting ivy-sort-matches-functions-alist)) + (funcall fun name candidates)) + ((and (eq ivy--regex-function #'ivy--regex-fuzzy) + (ivy--flx-available-p)) + (ivy--flx-sort name candidates)) + (t + candidates)))) + +(defun ivy--prefix-sort (name candidates) + "Re-sort candidates by NAME. +All CANDIDATES are assumed to match NAME. +Prefix matches to NAME are put ahead of the list." + (if (or (string= name "") + (= (aref name 0) ?^)) + candidates + (let ((re-prefix (concat "\\`" (funcall ivy--regex-function name))) + res-prefix + res-noprefix) + (dolist (s candidates) + (push s (if (string-match-p re-prefix s) + res-prefix + res-noprefix))) + (nconc + (nreverse res-prefix) + (nreverse res-noprefix))))) + +(defvar ivy--virtual-buffers nil + "Store the virtual buffers alist.") + +(defun ivy-re-to-str (re) + "Transform RE to a string. + +Functions like `ivy--regex-ignore-order' return a cons list. +This function extracts a string from the cons list." + (if (consp re) (caar re) re)) + +(defun ivy-sort-function-buffer (name candidates) + "Re-sort candidates by NAME. +CANDIDATES is a list of buffer names each containing NAME. +Sort open buffers before virtual buffers, and prefix matches +before substring matches." + (if (or (string= name "") + (= (aref name 0) ?^)) + candidates + (let* ((base-re (ivy-re-to-str (funcall ivy--regex-function name))) + (re-prefix (concat "\\`\\*?" base-re)) + res-prefix + res-noprefix + res-virtual-prefix + res-virtual-noprefix) + (dolist (s candidates) + (let ((virtual (assoc s ivy--virtual-buffers)) + (prefixed (string-match-p re-prefix s))) + (push s (cond ((and virtual prefixed) res-virtual-prefix) + (virtual res-virtual-noprefix) + (prefixed res-prefix) + (t res-noprefix))))) + (nconc + (nreverse res-prefix) + (nreverse res-noprefix) + (nreverse res-virtual-prefix) + (nreverse res-virtual-noprefix))))) + +(defvar ivy-flx-limit 200 + "Used to conditionally turn off flx sorting. + +When the amount of matching candidates exceeds this limit, then +no sorting is done.") + +(defvar ivy--recompute-index-inhibit nil + "When non-nil, `ivy--recompute-index' is a no-op.") + +(defun ivy--recompute-index (re-str cands) + "Recompute index of selected candidate matching RE-STR. +CANDS are the current candidates." + (let ((caller (ivy-state-caller ivy-last)) + (func (or (ivy-alist-setting ivy-index-functions-alist) + #'ivy-recompute-index-zero)) + (case-fold-search (ivy--case-fold-p re-str)) + (preselect (ivy-state-preselect ivy-last)) + (current (ivy-state-current ivy-last)) + (empty (string= re-str ""))) + (unless (or (memq this-command '(ivy-resume ivy-partial-or-done)) + ivy--recompute-index-inhibit) + (let ((index (cond + ((or empty (string= re-str "^")) + (ivy--preselect-index preselect cands)) + ((and (> (length cands) 10000) (eq func #'ivy-recompute-index-zero)) + 0) + ((cl-position (string-remove-prefix "^" re-str) + cands + :test #'ivy--case-fold-string=)) + ((and (ivy--completing-fname-p) + (cl-position (concat re-str "/") + cands + :test #'ivy--case-fold-string=))) + ((and (eq caller 'ivy-switch-buffer) + (not empty)) + (or (cl-position current cands :test #'string=) + 0)) + ((and (not empty) + (not (eq caller 'swiper)) + (not (and (eq ivy--regex-function #'ivy--regex-fuzzy) + (ivy--flx-available-p) + ;; Limit to configured number of candidates + (null (nthcdr ivy-flx-limit cands)))) + ;; If there was a preselected candidate, don't try to + ;; keep it selected even if the regexp still matches it. + ;; See issue #1563. See also `ivy--preselect-index', + ;; which this logic roughly mirrors. + (not (or + (and (integerp preselect) + (= ivy--index preselect)) + (equal current preselect) + (and (ivy--regex-p preselect) + (stringp current) + (string-match-p preselect current)))) + ivy--old-cands + (cl-position current cands :test #'equal))) + ((funcall func re-str cands)) + (t 0)))) + (ivy-set-index index))))) + +(defun ivy-recompute-index-swiper (_re-str cands) + "Recompute index of selected candidate when using `swiper'. +CANDS are the current candidates." + (condition-case nil + (let ((tail (nthcdr ivy--index ivy--old-cands)) + idx) + (if (and tail ivy--old-cands (not (equal "^" ivy--old-re))) + (progn + (while (and tail (null idx)) + ;; Compare with eq to handle equal duplicates in cands + (setq idx (cl-position (pop tail) cands))) + (or + idx + (1- (length cands)))) + (if ivy--old-cands + ivy--index + ;; already in ivy-state-buffer + (let ((n (line-number-at-pos)) + (res 0) + (i 0)) + (dolist (c cands) + (when (eq n (get-text-property 0 'swiper-line-number c)) + (setq res i)) + (cl-incf i)) + res)))) + (error 0))) + +(defun ivy-recompute-index-swiper-backward (re-str cands) + "Recompute index of selected candidate when using `swiper-backward'. +CANDS are the current candidates." + (let ((idx (ivy-recompute-index-swiper re-str cands))) + (if (or (= idx -1) + (<= (get-text-property 0 'swiper-line-number (nth idx cands)) + (line-number-at-pos))) + idx + (- idx 1)))) + +(defun ivy-recompute-index-swiper-async (_re-str cands) + "Recompute index of selected candidate when using `swiper' asynchronously. +CANDS are the current candidates." + (if (null ivy--old-cands) + (let ((ln (with-ivy-window + (line-number-at-pos)))) + (or + ;; closest to current line going forwards + (cl-position-if (lambda (x) + (>= (string-to-number x) ln)) + cands) + ;; closest to current line going backwards + (1- (length cands)))) + (let ((tail (nthcdr ivy--index ivy--old-cands)) + idx) + (if (and tail ivy--old-cands (not (equal "^" ivy--old-re))) + (progn + (while (and tail (null idx)) + ;; Compare with `equal', since the collection is re-created + ;; each time with `split-string' + (setq idx (cl-position (pop tail) cands :test #'equal))) + (or idx 0)) + ivy--index)))) + +(defun ivy-recompute-index-swiper-async-backward (re-str cands) + "Recompute index of selected candidate when using `swiper-backward' +asynchronously. CANDS are the current candidates." + (if (= (length cands) 0) + 0 + (let ((idx (ivy-recompute-index-swiper-async re-str cands))) + (if + (<= (string-to-number (nth idx cands)) + (with-ivy-window (line-number-at-pos))) + idx + (- idx 1))))) + +(defun ivy-recompute-index-zero (_re-str _cands) + "Recompute index of selected candidate. +This function serves as a fallback when nothing else is available." + 0) + +(defcustom ivy-minibuffer-faces + '(ivy-minibuffer-match-face-1 + ivy-minibuffer-match-face-2 + ivy-minibuffer-match-face-3 + ivy-minibuffer-match-face-4) + "List of `ivy' faces for minibuffer group matches." + :type '(repeat :tag "Faces" + (choice + (const ivy-minibuffer-match-face-1) + (const ivy-minibuffer-match-face-2) + (const ivy-minibuffer-match-face-3) + (const ivy-minibuffer-match-face-4) + (face :tag "Other face")))) + +(defun ivy--minibuffer-face (n) + "Return Nth face from `ivy-minibuffer-faces'. +N wraps around, but skips the first element of the list." + (let ((tail (cdr ivy-minibuffer-faces))) + (nth (mod (+ n 2) (length tail)) tail))) + +(defun ivy--flx-propertize (x) + "X is (cons (flx-score STR ...) STR)." + (let ((str (copy-sequence (cdr x))) + (i 0) + (last-j -2)) + (dolist (j (cdar x)) + (unless (eq j (1+ last-j)) + (cl-incf i)) + (setq last-j j) + (add-face-text-property j (1+ j) (ivy--minibuffer-face i) nil str)) + str)) + +(defun ivy--flx-sort (name cands) + "Sort according to closeness to string NAME the string list CANDS." + (condition-case nil + (let* ((bolp (= (string-to-char name) ?^)) + ;; An optimized regex for fuzzy matching + ;; "abc" → "^[^a]*a[^b]*b[^c]*c" + (fuzzy-regex (concat "\\`" + (and bolp (regexp-quote (substring name 1 2))) + (mapconcat + (lambda (x) + (setq x (char-to-string x)) + (concat "[^" x "]*" (regexp-quote x))) + (if bolp (substring name 2) name) + ""))) + ;; Strip off the leading "^" for flx matching + (flx-name (if bolp (substring name 1) name)) + cands-left + cands-to-sort) + + ;; Filter out non-matching candidates + (dolist (cand cands) + (when (string-match-p fuzzy-regex cand) + (push cand cands-left))) + + ;; pre-sort the candidates by length before partitioning + (setq cands-left (static-if (bound-and-true-p ivy--new-sort-p) + (sort cands-left :key #'length :in-place t) + (cl-sort cands-left #'< :key #'length))) + + ;; partition the candidates into sorted and unsorted groups + (dotimes (_ (min (length cands-left) ivy-flx-limit)) + (push (pop cands-left) cands-to-sort)) + + (nconc + (static-if (bound-and-true-p ivy--new-sort-p) + (sort cands-to-sort :in-place t + :key (lambda (cand) + (let ((s (flx-score cand flx-name ivy--flx-cache))) + ;; Sort by decreasing score, increasing length. + (cons (- (car s)) (length cand))))) + ;; Compute all of the flx scores in one pass and sort. + (mapcar #'car + (sort (mapcar + (lambda (cand) + (cons cand + (car (flx-score cand flx-name + ivy--flx-cache)))) + cands-to-sort) + (lambda (c1 c2) + ;; Break ties by length + (if (/= (cdr c1) (cdr c2)) + (> (cdr c1) + (cdr c2)) + (< (length (car c1)) + (length (car c2)))))))) + + ;; Add the unsorted candidates + cands-left)) + (error cands))) + +(defun ivy--truncate-string (str width) + "Truncate STR to WIDTH." + (truncate-string-to-width str width nil nil t)) + +(defun ivy--format-function-generic (selected-fn other-fn cands separator) + "Transform candidates into a string for minibuffer. +SELECTED-FN is called for the selected candidate, OTHER-FN for the others. +Both functions take one string argument each. CANDS is a list of candidates +and SEPARATOR is used to join them." + (let ((i -1)) + (mapconcat + (lambda (str) + (let ((curr (eq (cl-incf i) ivy--window-index))) + (if curr + (funcall selected-fn str) + (funcall other-fn str)))) + cands + separator))) + +(defun ivy-format-function-default (cands) + "Transform CANDS into a multiline string for the minibuffer. +Add the face `ivy-current-match' to the selected candidate." + (ivy--format-function-generic + (lambda (str) + (ivy--add-face str 'ivy-current-match)) + #'identity + cands + "\n")) + +(defun ivy-format-function-arrow (cands) + "Transform CANDS into a multiline string for the minibuffer. +Like `ivy-format-function-default', but also prefix the selected +candidate with an arrow \">\"." + (ivy--format-function-generic + (lambda (str) + (concat "> " (ivy--add-face str 'ivy-current-match))) + (lambda (str) + (concat " " str)) + cands + "\n")) + +(defun ivy-format-function-line (cands) + "Transform CANDS into a multiline string for the minibuffer. +Like `ivy-format-function-default', but extend highlighting of +the selected candidate to the window edge. + +Note that since Emacs 27, `ivy-current-match' needs to have a +non-nil :extend attribute. This is the case by default, but it +also needs to be preserved by the current theme." + (ivy--format-function-generic + (lambda (str) + (ivy--add-face (concat str "\n") 'ivy-current-match)) + (lambda (str) + (concat str "\n")) + cands + "")) + +(defun ivy-format-function-arrow-line (cands) + "Transform CANDS into a multiline string for the minibuffer. +This combines the \">\" prefix of `ivy-format-function-arrow' +with the extended highlighting of `ivy-format-function-line'." + (ivy--format-function-generic + (lambda (str) + (concat "> " (ivy--add-face (concat str "\n") 'ivy-current-match))) + (lambda (str) + (concat " " str "\n")) + cands + "")) + +(defun ivy--highlight-ignore-order (str) + "Highlight STR, using the ignore-order method." + (when (consp ivy--old-re) + (let ((i 1)) + (dolist (re ivy--old-re) + (when (string-match (car re) str) + (add-face-text-property + (match-beginning 0) (match-end 0) + (ivy--minibuffer-face i) + nil str)) + (cl-incf i)))) + str) + +(defun ivy--highlight-fuzzy (str) + "Highlight STR, using the fuzzy method." + (if (and (eq (ivy-alist-setting ivy-re-builders-alist) #'ivy--regex-fuzzy) + (ivy--flx-available-p)) + (let ((flx-name (string-remove-prefix "^" ivy-text))) + (ivy--flx-propertize + (cons (flx-score str flx-name ivy--flx-cache) str))) + (ivy--highlight-default str))) + +(defcustom ivy-use-group-face-if-no-groups t + "If t, and the expression has no subgroups, highlight whole match as a group. + +It will then use the second face (first of the \"group\" faces) +of `ivy-minibuffer-faces'. Otherwise, always use the first face +in this case." + :type 'boolean) + +(defun ivy--positive-regexps () + "Return a list of the positive regexps in `ivy-regex'." + (let ((re ivy-regex)) + (if (listp re) + (cl-mapcan (lambda (x) (and (cdr x) (list (car x)))) re) + (list re)))) + +(defun ivy--highlight-default (str) + "Highlight STR, using the default method." + (let ((regexps (ivy--positive-regexps)) + start) + (dolist (re regexps) + (ignore-errors + (while (and (string-match re str start) + (> (- (match-end 0) (match-beginning 0)) 0)) + (setq start (match-end 0)) + (let ((i 0) + (n 0) + prev) + (while (<= i ivy--subexps) + (let ((beg (match-beginning i)) + (end (match-end i))) + (when (and beg end) + (unless (or (and prev (= prev beg)) + (zerop i)) + (cl-incf n)) + (let ((face + (cond ((and ivy-use-group-face-if-no-groups + (zerop ivy--subexps)) + (cadr ivy-minibuffer-faces)) + ((zerop i) + (car ivy-minibuffer-faces)) + (t + (ivy--minibuffer-face n))))) + (add-face-text-property beg end face nil str)) + (unless (zerop i) + (setq prev end)))) + (cl-incf i))))))) + str) + +(defun ivy--format-minibuffer-line (str &optional affix) + "Format line STR for use in minibuffer. +AFFIX is either the (PREFIX SUFFIX) cdr returned by +`affixation-function', or the result of `annotation-function'." + (let* ((str (ivy-cleanup-string (copy-sequence str))) + (str (cond + ((not (eq ivy-display-style 'fancy)) str) + ((memq (ivy-state-caller ivy-last) ivy-highlight-grep-commands) + (let* ((start (if (string-match "\\`[^:]+:\\(?:[^:]+:\\)?" str) + (match-end 0) 0)) + (file (substring str 0 start)) + (match (substring str start))) + (concat file (funcall ivy--highlight-function match)))) + ((funcall ivy--highlight-function str)))) + (mouse '( mouse-face ivy-minibuffer-match-highlight + help-echo ivy--help-echo))) + (add-text-properties 0 (length str) mouse str) + (cond ((consp affix) + (concat (nth 0 affix) str (nth 1 affix))) + (affix + ;; Existing face takes priority. + (unless (text-property-not-all 0 (length affix) 'face nil affix) + (setq affix (ivy-append-face affix 'ivy-completions-annotations))) + (concat str affix)) + (str)))) + +(defun ivy-read-file-transformer (str) + "Transform candidate STR when reading files." + (if (ivy--dirname-p str) + (propertize str 'face 'ivy-subdir) + str)) + +(defun ivy--minibuffer-index-bounds (idx len wnd-len) + (let* ((half-height (/ wnd-len 2)) + (start (max 0 + (min (- idx half-height) + (- len (1- wnd-len))))) + (end (min (+ start (1- wnd-len)) len))) + (list start end (- idx start)))) + +(defun ivy--format (cands) + "Return a string for CANDS suitable for display in the minibuffer. +CANDS is a list of candidates that :display-transformer can turn into strings." + (setq ivy--length (length cands)) + (when (>= ivy--index ivy--length) + (ivy-set-index (max (1- ivy--length) 0))) + (if (null cands) + (setf (ivy-state-current ivy-last) "") + (let ((cur (nth ivy--index cands))) + (setf (ivy-state-current ivy-last) (if (stringp cur) + (copy-sequence cur) + cur))) + (let* ((bnd (ivy--minibuffer-index-bounds + ivy--index ivy--length ivy-height)) + (wnd-cands (cl-subseq cands (car bnd) (cadr bnd))) + (case-fold-search (ivy--case-fold-p (ivy-re-to-str ivy-regex))) + transformer-fn) + (setq ivy--window-index (nth 2 bnd)) + (when (setq transformer-fn (ivy-state-display-transformer-fn ivy-last)) + (with-ivy-window + (with-current-buffer (ivy-state-buffer ivy-last) + (setq wnd-cands (mapcar transformer-fn wnd-cands))))) + (ivy--wnd-cands-to-str wnd-cands)))) + +(defalias 'ivy--metadata-get + (if (>= emacs-major-version 30) + #'completion-metadata-get + (lambda (metadata prop) + (or (completion-metadata-get metadata prop) + (plist-get completion-extra-properties + (or (get prop 'ivy--metadata-kwd) + (put prop 'ivy--metadata-kwd + (intern (concat ":" (symbol-name prop))))))))) + "Compatibility shim for Emacs 30 `completion-metadata-get'. +\n(fn METADATA PROP)") + +(defun ivy--wnd-cands-to-str (wnd-cands) + (let* ((metadata (unless (ivy-state-dynamic-collection ivy-last) + (completion-metadata "" minibuffer-completion-table + minibuffer-completion-predicate))) + (affix (ivy--metadata-get metadata 'affixation-function)) + (annot (or affix (ivy--metadata-get metadata 'annotation-function))) + (fmt (cond (affix + (lambda (triple) + (ivy--format-minibuffer-line (car triple) (cdr triple)))) + (annot + (lambda (cand) + (ivy--format-minibuffer-line cand (funcall annot cand)))) + (#'ivy--format-minibuffer-line))) + (str (funcall (ivy-alist-setting ivy-format-functions-alist) + (condition-case nil + (mapcar fmt (if affix (funcall affix wnd-cands) + wnd-cands)) + (error wnd-cands))))) + (concat "\n" (ivy--remove-props str 'read-only)))) + +(defvar recentf-list) +(defvar bookmark-alist) + +(defcustom ivy-virtual-abbreviate 'name + "The mode of abbreviation for virtual buffer names." + :type '(choice + (const :tag "Only name" name) + (const :tag "Abbreviated path" abbreviate) + (const :tag "Full path" full) + ;; eventually, uniquify + )) +(declare-function bookmark-maybe-load-default-file "bookmark") +(declare-function bookmark-get-filename "bookmark") + +(defun ivy--virtual-buffers () + "Adapted from `ido-add-virtual-buffers-to-list'." + (require 'bookmark) + (unless recentf-mode + (recentf-mode 1)) + (bookmark-maybe-load-default-file) + (let* ((vb-bkm (delete " - no file -" + (delq nil (mapcar #'bookmark-get-filename + bookmark-alist)))) + (vb-list (cond ((eq ivy-use-virtual-buffers 'recentf) + recentf-list) + ((eq ivy-use-virtual-buffers 'bookmarks) + vb-bkm) + (ivy-use-virtual-buffers + (append recentf-list vb-bkm)) + (t nil))) + virtual-buffers) + (dolist (head vb-list) + (let* ((file-name (if (stringp head) + head + (cdr head))) + (name (cond ((eq ivy-virtual-abbreviate 'name) + (file-name-nondirectory file-name)) + ((eq ivy-virtual-abbreviate 'abbreviate) + (abbreviate-file-name file-name)) + (t + (expand-file-name file-name))))) + (when (equal name "") + (setq name + (if (consp head) + (car head) + (file-name-nondirectory (directory-file-name file-name))))) + (unless (or (equal name "") + (get-file-buffer file-name) + (assoc name virtual-buffers)) + (push (cons (copy-sequence name) file-name) virtual-buffers)))) + (when virtual-buffers + (dolist (comp virtual-buffers) + (put-text-property 0 (length (car comp)) + 'face 'ivy-virtual + (car comp))) + (setq ivy--virtual-buffers (nreverse virtual-buffers)) + (mapcar #'car ivy--virtual-buffers)))) + +(defcustom ivy-ignore-buffers '("\\` " "\\`\\*tramp/") + "List of regexps or functions matching buffer names to ignore." + :type '(repeat (choice regexp function))) + +(defvar ivy-switch-buffer-faces-alist '((dired-mode . ivy-subdir) + (org-mode . ivy-org)) + "Store face customizations for `ivy-switch-buffer'. +Each KEY is `major-mode', each VALUE is a face name.") + +(defun ivy--buffer-list (str &optional virtual predicate) + "Return the buffers that match STR. +If VIRTUAL is non-nil, add virtual buffers. +If optional argument PREDICATE is non-nil, use it to test each +possible match. See `all-completions' for further information." + (delete-dups + (nconc + (all-completions str #'internal-complete-buffer predicate) + (and virtual + (ivy--virtual-buffers))))) + +(defvar ivy-views (and nil + `(("ivy + *scratch* {}" + (vert + (file ,(expand-file-name "ivy.el")) + (buffer "*scratch*"))) + ("swiper + *scratch* {}" + (horz + (file ,(expand-file-name "swiper.el")) + (buffer "*scratch*"))))) + "Store window configurations selectable by `ivy-switch-buffer'. + +The default value is given as an example. + +Each element is a list of (NAME VIEW). NAME is a string, it's +recommended to end it with a distinctive snippet e.g. \"{}\" so +that it's easy to distinguish the window configurations. + +VIEW is either a TREE or a window-configuration (see +`ivy--get-view-config'). + +TREE is a nested list with the following valid cars: +- vert: split the window vertically +- horz: split the window horizontally +- file: open the specified file +- buffer: open the specified buffer + +TREE can be nested multiple times to have multiple window splits.") + +(defun ivy-default-view-name () + "Return default name for new view." + (let* ((default-view-name + (concat "{} " + (mapconcat #'identity + (sort + (mapcar (lambda (w) + (let* ((b (window-buffer w)) + (f (buffer-file-name b))) + (if f + (file-name-nondirectory f) + (buffer-name b)))) + (window-list)) + #'string-lessp) + " "))) + (view-name-re (concat "\\`" + (regexp-quote default-view-name) + " \\([0-9]+\\)")) + old-view) + (cond ((setq old-view + (cl-find-if + (lambda (x) + (string-match view-name-re (car x))) + ivy-views)) + (format "%s %d" + default-view-name + (1+ (string-to-number + (match-string 1 (car old-view)))))) + ((assoc default-view-name ivy-views) + (concat default-view-name " 1")) + (t + default-view-name)))) + +(defun ivy--get-view-config () + "Get `current-window-configuration' for `ivy-views'." + (dolist (w (window-list)) + (set-window-parameter w 'ivy-view-data + (with-current-buffer (window-buffer w) + (cond (buffer-file-name + (list 'file buffer-file-name (point))) + ((eq major-mode 'dired-mode) + (list 'file default-directory (point))) + (t + (list 'buffer (buffer-name) (point))))))) + (let ((window-persistent-parameters + (append window-persistent-parameters + (list (cons 'ivy-view-data t))))) + (current-window-configuration))) + +(defun ivy-push-view (&optional arg) + "Push the current window tree on `ivy-views'. + +When ARG is non-nil, replace a selected item on `ivy-views'. + +Currently, the split configuration (i.e. horizontal or vertical) +and point positions are saved, but the split positions aren't. +Use `ivy-pop-view' to delete any item from `ivy-views'." + (interactive "P") + (let* ((view (ivy--get-view-config)) + (view-name + (if arg + (ivy-read "Update view: " ivy-views) + (ivy-read "Name view: " nil + :initial-input (ivy-default-view-name))))) + (when view-name + (let ((x (assoc view-name ivy-views))) + (if x + (setcdr x (list view)) + (push (list view-name view) ivy-views)))))) + +(defun ivy-pop-view-action (view) + "Delete VIEW from `ivy-views'." + (setq ivy-views (delete view ivy-views)) + (setq ivy--all-candidates + (delete (car view) ivy--all-candidates)) + (setq ivy--old-cands nil)) + +(defun ivy-pop-view () + "Delete a view to delete from `ivy-views'." + (interactive) + (ivy-read "Pop view: " ivy-views + :preselect (caar ivy-views) + :action #'ivy-pop-view-action + :caller 'ivy-pop-view)) + +(defun ivy-source-views () + "Return the name of the views saved in `ivy-views'." + (mapcar #'car ivy-views)) + +(ivy-set-sources + 'ivy-switch-buffer + '((original-source) + (ivy-source-views))) + +(defun ivy-set-view-recur (view) + "Set VIEW recursively." + (cond ((window-configuration-p view) + (set-window-configuration view) + (dolist (w (window-list)) + (with-selected-window w + (ivy-set-view-recur + (window-parameter w 'ivy-view-data))))) + ((eq (car view) 'vert) + (let* ((wnd1 (selected-window)) + (wnd2 (split-window-vertically)) + (views (cdr view)) + (v (pop views)) + (temp-wnd)) + (with-selected-window wnd1 + (ivy-set-view-recur v)) + (while (setq v (pop views)) + (with-selected-window wnd2 + (when views + (setq temp-wnd (split-window-vertically))) + (ivy-set-view-recur v) + (when views + (setq wnd2 temp-wnd)))))) + ((eq (car view) 'horz) + (let* ((wnd1 (selected-window)) + (wnd2 (split-window-horizontally)) + (views (cdr view)) + (v (pop views)) + (temp-wnd)) + (with-selected-window wnd1 + (ivy-set-view-recur v)) + (while (setq v (pop views)) + (with-selected-window wnd2 + (when views + (setq temp-wnd (split-window-horizontally))) + (ivy-set-view-recur v) + (when views + (setq wnd2 temp-wnd)))))) + ((eq (car view) 'file) + (let* ((name (nth 1 view)) + (virtual (assoc name ivy--virtual-buffers)) + buffer) + (cond ((setq buffer (get-buffer name)) + (switch-to-buffer buffer nil 'force-same-window)) + (virtual + (find-file (cdr virtual))) + ((file-exists-p name) + (find-file name)))) + (when (and (> (length view) 2) + (numberp (nth 2 view))) + (goto-char (nth 2 view)))) + ((eq (car view) 'buffer) + (switch-to-buffer (nth 1 view)) + (when (and (> (length view) 2) + (numberp (nth 2 view))) + (goto-char (nth 2 view)))) + ((eq (car view) 'sexp) + (eval (nth 1 view))))) + +(defun ivy--switch-buffer-action (buffer) + "Switch to BUFFER. +BUFFER may be a string or nil." + (if (zerop (length buffer)) + (switch-to-buffer + ivy-text nil 'force-same-window) + (let ((virtual (assoc buffer ivy--virtual-buffers)) + (view (assoc buffer ivy-views))) + (cond ((and virtual + (not (get-buffer buffer))) + (find-file (cdr virtual))) + (view + (delete-other-windows) + (let ( + ;; silence "Directory has changed on disk" + (inhibit-message t)) + (ivy-set-view-recur (cadr view)))) + (t + (switch-to-buffer + buffer nil 'force-same-window)))))) + +(defun ivy--switch-buffer-other-window-action (buffer) + "Switch to BUFFER in other window. +BUFFER may be a string or nil." + (if (zerop (length buffer)) + (switch-to-buffer-other-window ivy-text) + (let ((virtual (assoc buffer ivy--virtual-buffers))) + (if (and virtual + (not (get-buffer buffer))) + (find-file-other-window (cdr virtual)) + (switch-to-buffer-other-window buffer))))) + +(defun ivy--rename-buffer-action (buffer) + "Rename BUFFER." + (let ((new-name (read-string "Rename buffer (to new name): "))) + (with-current-buffer buffer + (rename-buffer new-name)))) + +(defun ivy--find-file-action (buffer) + "Find file from BUFFER's directory." + (let* ((virtual (assoc buffer ivy--virtual-buffers)) + (default-directory (if virtual + (file-name-directory (cdr virtual)) + (buffer-local-value 'default-directory + (or (get-buffer buffer) + (current-buffer)))))) + (call-interactively (if (functionp 'counsel-find-file) + #'counsel-find-file + #'find-file)))) + +(defun ivy--kill-buffer-or-virtual (buffer) + (if (get-buffer buffer) + (kill-buffer buffer) + (setq recentf-list (delete + (cdr (assoc buffer ivy--virtual-buffers)) + recentf-list)))) + +(defun ivy--kill-current-candidate () + (setf (ivy-state-preselect ivy-last) ivy--index) + (setq ivy--old-re nil) + (setq ivy--all-candidates (delete (ivy-state-current ivy-last) ivy--all-candidates)) + (let ((ivy--recompute-index-inhibit t)) + (ivy--exhibit))) + +(defun ivy--kill-current-candidate-buffer () + (setf (ivy-state-preselect ivy-last) ivy--index) + (setq ivy--old-re nil) + (setq ivy--all-candidates (ivy--buffer-list "" ivy-use-virtual-buffers + (ivy-state-predicate ivy-last))) + (let ((ivy--recompute-index-inhibit t)) + (ivy--exhibit))) + +(defun ivy--kill-buffer-action (buffer) + "Kill BUFFER." + (ivy--kill-buffer-or-virtual buffer) + (unless (buffer-live-p (ivy-state-buffer ivy-last)) + (setf (ivy-state-buffer ivy-last) + (with-ivy-window (current-buffer)))) + (ivy--kill-current-candidate-buffer)) + +(defvar ivy-switch-buffer-map + (let ((map (make-sparse-keymap))) + (ivy-define-key map (kbd "C-k") #'ivy-switch-buffer-kill) + map)) + +(defun ivy-switch-buffer-kill () + "When at end-of-line, kill the current buffer in `ivy-switch-buffer'. +Otherwise, forward to `ivy-kill-line'." + (interactive) + (if (not (eolp)) + (ivy-kill-line) + (ivy--kill-buffer-action + (ivy-state-current ivy-last)))) + +(ivy-set-actions + 'ivy-switch-buffer + '(("f" + ivy--find-file-action + "find file") + ("j" + ivy--switch-buffer-other-window-action + "other window") + ("k" + ivy--kill-buffer-action + "kill") + ("r" + ivy--rename-buffer-action + "rename"))) + +(ivy-set-actions + t + '(("i" ivy--action-insert "insert") + ("w" ivy--action-copy "copy"))) + +(defun ivy--trim-grep-line-number (x) + (if (string-match ":[0-9]+:" x) + (substring x (match-end 0)) + x)) + +(defun ivy--action-insert (x) + (insert + (if (stringp x) + (ivy--trim-grep-line-number x) + (car x)))) + +(defun ivy--action-copy (x) + (kill-new + (if (stringp x) + (ivy--trim-grep-line-number x) + (car x)))) + +(defun ivy--switch-buffer-matcher (regexp candidates) + "Return REGEXP matching CANDIDATES. +Skip buffers that match `ivy-ignore-buffers'." + (if (string-match-p "^:" ivy-text) + (delete-dups + (cl-delete-if-not + (lambda (s) + (when (/= (string-to-char s) ?*) + (let ((b (get-buffer s))) + (and b (string-match-p + regexp (buffer-local-value 'default-directory b)))))) + (copy-sequence candidates))) + (let ((res (ivy--re-filter regexp candidates))) + (if (or (null ivy-use-ignore) + (null ivy-ignore-buffers)) + res + (or (cl-remove-if + (lambda (buf) + (cl-find-if + (lambda (f-or-r) + (if (functionp f-or-r) + (funcall f-or-r buf) + (string-match-p f-or-r buf))) + ivy-ignore-buffers)) + res) + (and (eq ivy-use-ignore t) + res)))))) + +(defun ivy-append-face (str face) + "Append to STR the property FACE." + (when face + (setq str (copy-sequence str)) + (add-face-text-property 0 (length str) face t str)) + str) + +(defun ivy--remote-buffer-p (buffer) + "Return non-nil if BUFFER object is visiting a remote file. +If that is the case, value is a string identifying the remote +connection." + (let ((dir (buffer-local-value 'default-directory buffer))) + (ignore-errors (file-remote-p dir)))) + +(defun ivy-switch-buffer-transformer (str) + "Transform candidate STR when switching buffers." + (let ((buf (get-buffer str))) + (cond ((not buf) str) + ((let ((remote (ivy--remote-buffer-p buf))) + (when remote + (format "%s (%s)" (ivy-append-face str 'ivy-remote) remote)))) + ((not (verify-visited-file-modtime buf)) + (ivy-append-face str 'ivy-modified-outside-buffer)) + ((buffer-modified-p buf) + (ivy-append-face str 'ivy-modified-buffer)) + (t + (let* ((mode (buffer-local-value 'major-mode buf)) + (face (cdr (assq mode ivy-switch-buffer-faces-alist)))) + (ivy-append-face str face)))))) + +(defun ivy-switch-buffer-occur (cands) + "Occur function for `ivy-switch-buffer' using `ibuffer'. +CANDS are the candidates to be displayed." + (unless cands + (setq cands (all-completions ivy-text #'internal-complete-buffer))) + (ibuffer + nil (buffer-name) + `((or ,@(cl-mapcan + (lambda (cand) + (unless (eq (get-text-property 0 'face cand) 'ivy-virtual) + `((name . ,(format "\\_<%s\\_>" (regexp-quote cand)))))) + cands))))) + +;;;###autoload +(defun ivy-switch-buffer () + "Switch to another buffer." + (interactive) + (ivy-read "Switch to buffer: " #'internal-complete-buffer + :keymap ivy-switch-buffer-map + :preselect (buffer-name (other-buffer (current-buffer))) + :action #'ivy--switch-buffer-action + :matcher #'ivy--switch-buffer-matcher + :caller 'ivy-switch-buffer)) + +(ivy-configure 'ivy-switch-buffer + :parent 'internal-complete-buffer + :occur #'ivy-switch-buffer-occur) + +;;;###autoload +(defun ivy-switch-view () + "Switch to one of the window views stored by `ivy-push-view'." + (interactive) + (let ((ivy-initial-inputs-alist + '((ivy-switch-buffer . "{}")))) + (ivy-switch-buffer))) + +;;;###autoload +(defun ivy-switch-buffer-other-window () + "Switch to another buffer in another window." + (interactive) + (ivy-read "Switch to buffer in other window: " #'internal-complete-buffer + :matcher #'ivy--switch-buffer-matcher + :preselect (buffer-name (other-buffer (current-buffer))) + :action #'ivy--switch-buffer-other-window-action + :keymap ivy-switch-buffer-map + :caller 'ivy-switch-buffer-other-window)) + +(ivy-configure 'ivy-switch-buffer-other-window + :parent 'ivy-switch-buffer) + +(defun ivy--yank-handle-case-fold (text) + (if (and (> (length ivy-text) 0) + (string= (downcase ivy-text) ivy-text)) + (downcase text) + text)) + +(defun ivy--yank-by (fn &rest args) + "Pull buffer text from current line into search string. +The region to extract is determined by the respective values of +point before and after applying FN to ARGS." + (let (text) + (with-ivy-window + (let ((beg (point)) + (bol (line-beginning-position)) + (eol (line-end-position)) + end) + (unwind-protect + (progn (apply fn args) + (setq end (goto-char (max bol (min (point) eol)))) + (setq text (buffer-substring-no-properties beg end)) + (ivy--pulse-region beg end)) + (unless text + (goto-char beg))))) + (when text + (insert (replace-regexp-in-string + " +" " " + (ivy--yank-handle-case-fold text) + t t))))) + +(defun ivy-yank-word (&optional arg) + "Pull next word from buffer into search string. +If optional ARG is non-nil, pull in the next ARG +words (previous if ARG is negative)." + (interactive "p") + (ivy--yank-by #'forward-word arg)) + +(defun ivy-yank-symbol (&optional arg) + "Pull next symbol from buffer into search string. +If optional ARG is non-nil, pull in the next ARG +symbols (previous if ARG is negative)." + (interactive "p") + (ivy--yank-by #'forward-symbol (or arg 1))) + +(defun ivy-yank-char (&optional arg) + "Pull next character from buffer into search string. +If optional ARG is non-nil, pull in the next ARG +characters (previous if ARG is negative)." + (interactive "p") + (ivy--yank-by #'forward-char arg)) + +(defvar ivy--pulse-overlay nil + "Overlay used to highlight yanked word.") + +(defvar ivy--pulse-timer nil + "Timer used to dispose of `ivy--pulse-overlay'.") + +(defcustom ivy-pulse-delay 0.5 + "Number of seconds to display `ivy-yanked-word' highlight. +When nil, disable highlighting." + :type '(choice + (number :tag "Delay in seconds") + (const :tag "Disable" nil))) + +(defun ivy--pulse-region (start end) + "Temporarily highlight text between START and END. +The \"pulse\" duration is determined by `ivy-pulse-delay'." + (when ivy-pulse-delay + (if ivy--pulse-overlay + (let ((ostart (overlay-start ivy--pulse-overlay)) + (oend (overlay-end ivy--pulse-overlay))) + (when (< end start) + (cl-rotatef start end)) + ;; Extend the existing overlay's region to include START..END, + ;; but only if the two regions are contiguous. + (move-overlay ivy--pulse-overlay + (if (= start oend) ostart start) + (if (= end ostart) oend end))) + (setq ivy--pulse-overlay (make-overlay start end)) + (overlay-put ivy--pulse-overlay 'face 'ivy-yanked-word)) + (when ivy--pulse-timer + (cancel-timer ivy--pulse-timer)) + (setq ivy--pulse-timer + (run-at-time ivy-pulse-delay nil #'ivy--pulse-cleanup)))) + +(defun ivy--pulse-cleanup () + "Cancel `ivy--pulse-timer' and delete `ivy--pulse-overlay'." + (when ivy--pulse-timer + (cancel-timer ivy--pulse-timer) + (setq ivy--pulse-timer nil)) + (when ivy--pulse-overlay + (delete-overlay ivy--pulse-overlay) + (setq ivy--pulse-overlay nil))) + +(defun ivy-kill-ring-save () + "Save the current candidates in the kill ring. +If the region is active, forward to `kill-ring-save' instead." + (interactive) + (if (use-region-p) + (call-interactively #'kill-ring-save) + (kill-new (string-join ivy--old-cands "\n")))) + +(defun ivy-insert-current () + "Make the current candidate into current input. +Don't finish completion." + (interactive) + (delete-minibuffer-contents) + (let ((end (and ivy--directory + (ivy--dirname-p (ivy-state-current ivy-last)) + -1))) + (insert (substring-no-properties + (ivy-state-current ivy-last) 0 end)))) + +(defun ivy-insert-current-full () + "Insert the current directory into the minibuffer." + (interactive) + (insert ivy--directory)) + +(defcustom ivy-preferred-re-builders + '((ivy--regex-plus . "ivy") + (ivy--regex-ignore-order . "order") + (ivy--regex-fuzzy . "fuzzy")) + "Alist of preferred re-builders with display names. +This list can be rotated with `ivy-rotate-preferred-builders'." + :type '(alist :key-type function :value-type string)) + +(defun ivy-rotate-preferred-builders () + "Switch to the next re builder in `ivy-preferred-re-builders'." + (interactive) + (when ivy-preferred-re-builders + (setq ivy--old-re nil) + (setq ivy--regex-function + (let ((cell (assq ivy--regex-function ivy-preferred-re-builders))) + (car (or (cadr (memq cell ivy-preferred-re-builders)) + (car ivy-preferred-re-builders))))))) + +(defun ivy-toggle-fuzzy () + "Toggle the re builder between `ivy--regex-fuzzy' and `ivy--regex-plus'." + (interactive) + (setq ivy--old-re nil) + (if (eq ivy--regex-function 'ivy--regex-fuzzy) + (setq ivy--regex-function 'ivy--regex-plus) + (setq ivy--regex-function 'ivy--regex-fuzzy))) + +(defun ivy--label-and-delete-dups (entries) + "Label ENTRIES with history indices." + (let ((ht (and entries (make-hash-table :test #'equal))) + (idx 0) + entry + accum) + (while (setq entry (pop entries)) + (unless (gethash entry ht) + (puthash entry t ht) + (push `(,entry . ,idx) accum)) + (cl-incf idx)) + (nreverse accum))) + +(defvar ivy--reverse-i-search-history nil + "Store the minibuffer history variable.") + +(defun ivy-reverse-i-search-kill () + "Remove the current item from minibuffer history." + (interactive) + (if (not (eolp)) + (ivy-kill-line) + (let ((current (ivy-state-current ivy-last)) + (history ivy--reverse-i-search-history)) + (cond ((booleanp history)) + ((symbolp history) + (set history (delete current (symbol-value history)))) + ((ring-p history) + ;; `ring-p' is autoloaded. + (declare-function ring-member "ring") + (declare-function ring-remove "ring") + (ring-remove history (ring-member history current))))) + (ivy--kill-current-candidate))) + +(defvar ivy-reverse-i-search-map + (let ((map (make-sparse-keymap))) + (ivy-define-key map (kbd "C-k") #'ivy-reverse-i-search-kill) + map)) + +(defun ivy-history-contents (history) + "Copy contents of HISTORY. +A copy is necessary so that we don't clobber any string attributes. +Also set `ivy--reverse-i-search-history' to HISTORY." + (prog1 (ivy--label-and-delete-dups + (cond ((booleanp history) ()) + ((symbolp history) + (copy-sequence (symbol-value history))) + ((ring-p history) + ;; `ring-p' is autoloaded. + (declare-function ring-elements "ring") + (ring-elements history)) + ((sequencep history) + (copy-sequence history)) + ((error "Expected a symbol, ring, or sequence: %S" history)))) + (setq ivy--reverse-i-search-history history))) + +(defun ivy-reverse-i-search () + "Enter a recursive `ivy-read' session using the current history. +The selected history element will be inserted into the minibuffer. +\\ +You can also delete an element from history with \\[ivy-reverse-i-search-kill]." + (interactive) + (cond + ((= (minibuffer-depth) 0) + (user-error + "This command is intended to be called from within `ivy-read'")) + ;; don't recur + ((and (> (minibuffer-depth) 1) + (eq (ivy-state-caller ivy-last) 'ivy-reverse-i-search))) + (t + (let ((enable-recursive-minibuffers t) + (old-last ivy-last)) + (ivy-read "Reverse-i-search: " + (ivy-history-contents (ivy-state-history ivy-last)) + :keymap ivy-reverse-i-search-map + :action (lambda (x) + (ivy--reset-state + (setq ivy-last old-last)) + (delete-minibuffer-contents) + (insert (substring-no-properties (car x))) + (ivy--cd-maybe)) + :caller 'ivy-reverse-i-search))))) + +(defun ivy-restrict-to-matches () + "Restrict candidates to current input and erase input." + (interactive) + (delete-minibuffer-contents) + (if (ivy-state-dynamic-collection ivy-last) + (progn + ;; By disabling `ivy-state-dynamic-collection', we lose the ability + ;; to clearly differentiate between ternary programmed completion + ;; functions and Ivy's unary dynamic collections (short of using + ;; `func-arity' or otherwise redesigning things). So we must also + ;; update the dynamic binding of `minibuffer-completion-table' to no + ;; longer hold a dynamic collection. + (setq minibuffer-completion-table ivy--old-cands) + (setq ivy--all-candidates ivy--old-cands) + (setf (ivy-state-collection ivy-last) ivy--old-cands) + (setf (ivy-state-dynamic-collection ivy-last) nil)) + (setq ivy--all-candidates + (ivy--filter ivy-text ivy--all-candidates)))) + +;;; Occur + +(defvar-local ivy-occur-last nil + "Buffer-local value of `ivy-last'. +Can't re-use `ivy-last' because using e.g. `swiper' in the same +buffer would modify `ivy-last'.") + +(defvar ivy-occur-mode-map + (let ((map (make-sparse-keymap))) + (ivy-define-key map [mouse-1] #'ivy-occur-click) + (ivy-define-key map (kbd "RET") #'ivy-occur-press-and-switch) + (ivy-define-key map (kbd "j") #'ivy-occur-next-line) + (ivy-define-key map (kbd "k") #'ivy-occur-previous-line) + (define-key map (kbd "h") #'backward-char) + (define-key map (kbd "l") #'forward-char) + (ivy-define-key map (kbd "f") #'ivy-occur-press) + (ivy-define-key map (kbd "g") #'ivy-occur-revert-buffer) + (ivy-define-key map (kbd "a") #'ivy-occur-read-action) + (ivy-define-key map (kbd "o") #'ivy-occur-dispatch) + (ivy-define-key map (kbd "c") #'ivy-occur-toggle-calling) + (define-key map (kbd "q") #'quit-window) + (define-key map (kbd "R") #'read-only-mode) + (ivy-define-key map (kbd "C-d") #'ivy-occur-delete-candidate) + (ivy-define-key map (kbd "F") #'ivy-occur-flush-lines) + map) + "Keymap for Ivy Occur mode.") + +(defun ivy-occur-toggle-calling () + "Toggle `ivy-calling'." + (interactive) + (if (setq ivy-calling (not ivy-calling)) + (progn + (setq mode-name "Ivy-Occur [calling]") + (ivy-occur-press)) + (setq mode-name "Ivy-Occur")) + (force-mode-line-update)) + +(defun ivy--find-occur-buffer () + (let ((cb (current-buffer))) + (cl-find-if + (lambda (b) + (with-current-buffer b + (and (eq major-mode 'ivy-occur-grep-mode) + (equal cb (ivy-state-buffer ivy-occur-last))))) + (buffer-list)))) + +(defun ivy--select-occur-buffer () + (let* ((ob (ivy--find-occur-buffer)) + (ow (cl-find-if (lambda (w) (equal ob (window-buffer w))) + (window-list)))) + (if ow + (select-window ow) + (pop-to-buffer ob)))) + +(defun ivy-occur-next-line (&optional arg) + "Move the cursor down ARG lines. +When `ivy-calling' isn't nil, call `ivy-occur-press'." + (interactive "p") + (let ((offset (cond ((derived-mode-p 'ivy-occur-grep-mode) 5) + ((derived-mode-p 'ivy-occur-mode) 2)))) + (if offset + (progn + (if (< (line-number-at-pos) offset) + (progn + (goto-char (point-min)) + (forward-line (1- offset))) + (forward-line arg) + (when (eolp) + (forward-line -1))) + (when ivy-calling + (ivy-occur-press))) + (ivy--select-occur-buffer) + (ivy-occur-next-line arg) + (ivy-occur-press-and-switch)))) + +(defun ivy-occur-previous-line (&optional arg) + "Move the cursor up ARG lines. +When `ivy-calling' isn't nil, call `ivy-occur-press'." + (interactive "p") + (let ((offset (cond ((derived-mode-p 'ivy-occur-grep-mode) 5) + ((derived-mode-p 'ivy-occur-mode) 2)))) + (if offset + (progn + (forward-line (- arg)) + (when (< (line-number-at-pos) offset) + (goto-char (point-min)) + (forward-line (1- offset))) + (when ivy-calling + (ivy-occur-press))) + (ivy--select-occur-buffer) + (ivy-occur-previous-line arg) + (ivy-occur-press-and-switch)))) + +(defun ivy-occur-next-error (n &optional reset) + "A `next-error-function' for `ivy-occur-mode'." + (interactive "p") + (when reset + (goto-char (point-min))) + (setq n (or n 1)) + (let ((ivy-calling t)) + (cond ((< n 0) (ivy-occur-previous-line (- n))) + (t (ivy-occur-next-line n)))) + ;; The window's point overrides the buffer's point every time it's redisplayed + (dolist (window (get-buffer-window-list nil nil t)) + (set-window-point window (point)))) + +(define-derived-mode ivy-occur-mode fundamental-mode "Ivy-Occur" + "Major mode for output from \\[ivy-occur]. + +\\{ivy-occur-mode-map}" + (setq-local view-read-only nil)) + +(defvar ivy-occur-grep-mode-map + (let ((map (copy-keymap ivy-occur-mode-map))) + (ivy-define-key map (kbd "C-x C-q") 'ivy-wgrep-change-to-wgrep-mode) + (ivy-define-key map "w" 'ivy-wgrep-change-to-wgrep-mode) + map) + "Keymap for Ivy Occur Grep mode.") + +(defun ivy-occur-delete-candidate () + (interactive) + (let ((inhibit-read-only t)) + (delete-region (line-beginning-position) + (1+ (line-end-position))))) + +(defun ivy-occur-flush-lines () + "Delete lines matching regex." + (interactive) + (let ((inhibit-read-only t)) + (call-interactively 'flush-lines))) + +(define-derived-mode ivy-occur-grep-mode grep-mode "Ivy-Occur" + "Major mode for output from \\[ivy-occur]. + +\\{ivy-occur-grep-mode-map}" + (setq-local view-read-only nil) + (when (fboundp 'wgrep-setup) + (wgrep-setup))) + +(defun ivy--starts-with-dotslash (str) + (string-match-p "\\`\\.[/\\]" str)) + +(defun ivy--occur-insert-lines (cands) + "Insert CANDS into `ivy-occur' buffer." + (font-lock-mode -1) + (dolist (cand cands) + (setq cand + (if (string-match "\\`\\(.*:[0-9]+:\\)\\(.*\\)\\'" cand) + (let ((file-and-line (match-string 1 cand)) + (grep-line (match-string 2 cand))) + (concat + (propertize file-and-line 'face 'ivy-grep-info) + (ivy--highlight-fuzzy grep-line))) + (ivy--highlight-fuzzy (copy-sequence cand)))) + (add-text-properties + 0 (length cand) + '(mouse-face + highlight + help-echo "mouse-1: call ivy-action") + cand) + (insert (if (ivy--starts-with-dotslash cand) "" " ") + cand ?\n))) + +(defun ivy--occur-default (cands) + "Insert CANDS into the current occur buffer." + (unless cands + (let ((coll (ivy-state-collection ivy-last))) + (when (arrayp coll) + (setq coll (all-completions "" coll (ivy-state-predicate ivy-last)))) + (setq cands (ivy--filter (ivy-state-text ivy-last) coll)))) + (ivy-occur-mode) + (insert (format "%d candidates:\n" (length cands))) + (ivy--occur-insert-lines cands) + (read-only-mode)) + +(defun ivy-occur () + "Stop completion and put the current candidates into a new buffer. + +The new buffer remembers current action(s). + +While in the *ivy-occur* buffer, selecting a candidate with RET or +a mouse click will call the appropriate action for that candidate. + +There is no limit on the number of *ivy-occur* buffers." + (interactive) + (if (not (window-minibuffer-p)) + (user-error "No completion session is active") + (let* ((caller (ivy-state-caller ivy-last)) + (occur-fn (or (plist-get ivy--occurs-list caller) + #'ivy--occur-default)) + (buffer + (generate-new-buffer + (format "*ivy-occur%s \"%s\"*" + (if caller + (concat " " (prin1-to-string caller)) + "") + ivy-text)))) + (with-current-buffer buffer + (funcall occur-fn + (if (ivy-state-dynamic-collection ivy-last) + (funcall (ivy-state-collection ivy-last) ivy-text) + ivy--old-cands)) + (setf (ivy-state-text ivy-last) ivy-text) + (setq ivy-occur-last ivy-last)) + (ivy-exit-with-action + (lambda (_) + (pop-to-buffer buffer) + (setq next-error-last-buffer buffer) + (setq-local next-error-function #'ivy-occur-next-error)))))) + +(defun ivy-occur-revert-buffer () + "Refresh the buffer making it up-to date with the collection. + +Currently only works for `swiper'. In that specific case, the +*ivy-occur* buffer becomes nearly useless as the original buffer +is updated, since the line numbers no longer match. + +Calling this function is as if you called `ivy-occur' on the +updated original buffer." + (interactive) + (let ((caller (ivy-state-caller ivy-occur-last)) + (ivy-last ivy-occur-last)) + (let ((inhibit-read-only t) + (line (line-number-at-pos)) + (text (ivy-state-text ivy-last))) + (erase-buffer) + (ivy-set-text text) + (funcall (or (plist-get ivy--occurs-list caller) + #'ivy--occur-default) + (and (ivy-state-dynamic-collection ivy-last) + (funcall (ivy-state-collection ivy-last) + text))) + (goto-char (point-min)) + (forward-line (1- line))) + (setq ivy-occur-last ivy-last))) + +(declare-function wgrep-change-to-wgrep-mode "ext:wgrep") + +(defun ivy-wgrep-change-to-wgrep-mode () + "Forward to `wgrep-change-to-wgrep-mode'." + (interactive) + (if (require 'wgrep nil 'noerror) + (wgrep-change-to-wgrep-mode) + (error "Package wgrep isn't installed"))) + +(defun ivy-occur-read-action () + "Select one of the available actions as the current one." + (interactive) + (let ((ivy-last ivy-occur-last)) + (ivy-read-action))) + +(defun ivy-occur-dispatch () + "Call one of the available actions on the current item." + (interactive) + (let* ((state-action (ivy-state-action ivy-occur-last)) + (actions (if (symbolp state-action) + state-action + (copy-sequence state-action)))) + (unwind-protect + (progn + (ivy-occur-read-action) + (ivy-occur-press)) + (setf (ivy-state-action ivy-occur-last) actions)))) + +(defun ivy-occur-click (event) + "Execute action for the current candidate. +EVENT gives the mouse position." + (interactive "e") + (let ((window (posn-window (event-end event))) + (pos (posn-point (event-end event)))) + (with-current-buffer (window-buffer window) + (goto-char pos) + (ivy-occur-press)))) + +(declare-function swiper--cleanup "swiper") +(declare-function swiper--add-overlays "swiper") +(defvar ivy-occur-timer nil) + +(defun ivy--occur-press-update-window () + (cond + ((memq (ivy-state-caller ivy-occur-last) + (append '(swiper swiper-isearch) ivy-highlight-grep-commands)) + (let ((window (ivy-state-window ivy-occur-last)) + (buffer (ivy-state-buffer ivy-occur-last))) + (when (buffer-live-p buffer) + (cond ((or (not (window-live-p window)) + (equal window (selected-window))) + (save-selected-window + (setf (ivy-state-window ivy-occur-last) + (display-buffer buffer)))) + ((not (equal (window-buffer window) buffer)) + (with-selected-window window + (switch-to-buffer buffer))))))) + + ((memq (ivy-state-caller ivy-occur-last) + '(counsel-describe-function + counsel-describe-variable + counsel-describe-symbol)) + (setf (ivy-state-window ivy-occur-last) + (selected-window)) + (selected-window)))) + +(defun ivy--occur-press-buffer () + (let ((buffer (ivy-state-buffer ivy-last))) + (if (buffer-live-p buffer) + buffer + (current-buffer)))) + +(defun ivy-occur-press () + "Execute action for the current candidate." + (interactive) + (ivy--occur-press-update-window) + (when (save-excursion + (beginning-of-line) + (looking-at "\\(?:.[/\\]\\| \\)\\(.*\\)$")) + (let* ((ivy-last ivy-occur-last) + (ivy-text (ivy-state-text ivy-last)) + (str (match-string 1)) + (offset (or (get-text-property 0 'offset str) 0)) + (coll (ivy-state-collection ivy-last)) + (action (ivy--get-action ivy-last)) + (ivy-exit 'done)) + (with-ivy-window + (with-current-buffer (ivy--occur-press-buffer) + (save-restriction + (widen) + (funcall action + (if (and (consp coll) + (consp (car coll))) + (assoc str coll) + (substring str offset))))) + (if (memq (ivy-state-caller ivy-last) + (append '(swiper swiper-isearch) ivy-highlight-grep-commands)) + (with-current-buffer (window-buffer (selected-window)) + (swiper--cleanup) + (swiper--add-overlays + (ivy--regex ivy-text) + (line-beginning-position) + (line-end-position) + (selected-window)) + (when (timerp ivy-occur-timer) + (cancel-timer ivy-occur-timer)) + (setq ivy-occur-timer + (run-at-time 1.0 nil 'swiper--cleanup)))))))) + +(defun ivy-occur-press-and-switch () + "Execute action for the current candidate and switch window." + (interactive) + (ivy-occur-press) + (select-window (ivy--get-window ivy-occur-last))) + +(defun ivy--marked-p () + (member (ivy-state-current ivy-last) ivy-marked-candidates)) + +(defun ivy--unmark (cand) + (setcar (member cand ivy--all-candidates) + (setcar (member cand ivy--old-cands) + (substring cand (length ivy-mark-prefix)))) + (setq ivy-marked-candidates + (delete cand ivy-marked-candidates))) + +(defun ivy--mark (cand) + (let ((marked-cand (copy-sequence (concat ivy-mark-prefix cand)))) + ;; Primarily for preserving `idx'. FIXME: the mark + ;; prefix shouldn't become part of the candidate! + (add-text-properties 0 (length ivy-mark-prefix) + (text-properties-at 0 cand) + marked-cand) + (setcar (member cand ivy--all-candidates) + (setcar (member cand ivy--old-cands) marked-cand)) + (setq ivy-marked-candidates + (nconc ivy-marked-candidates (list marked-cand))))) + +(defun ivy-mark () + "Mark the selected candidate and move to the next one. + +In `ivy-call', :action will be called in turn for all marked +candidates. + +However, if :multi-action was supplied to `ivy-read', then it +will be called with `ivy-marked-candidates'. This way, it can +make decisions based on the whole marked list." + (interactive) + (unless (ivy--marked-p) + (ivy--mark (ivy-state-current ivy-last))) + (ivy-next-line)) + +(defun ivy-unmark () + "Unmark the selected candidate and move to the next one." + (interactive) + (when (ivy--marked-p) + (ivy--unmark (ivy-state-current ivy-last))) + (ivy-next-line)) + +(defun ivy-unmark-backward () + "Move to the previous candidate and unmark it." + (interactive) + (ivy-previous-line) + (ivy--exhibit) + (when (ivy--marked-p) + (ivy--unmark (ivy-state-current ivy-last)))) + +(defun ivy-toggle-marks () + "Toggle mark for all narrowed candidates." + (interactive) + (dolist (cand ivy--old-cands) + (if (member cand ivy-marked-candidates) + (ivy--unmark cand) + (ivy--mark cand)))) + +(defconst ivy-help-file (let ((default-directory + (if load-file-name + (file-name-directory load-file-name) + default-directory))) + (if (file-exists-p "ivy-help.org") + (expand-file-name "ivy-help.org") + (if (file-exists-p "doc/ivy-help.org") + (expand-file-name "doc/ivy-help.org")))) + "The file for `ivy-help'.") + +(defvar org-hide-emphasis-markers) + +(defun ivy-help () + "Help for `ivy'." + (interactive) + (let ((buf (get-buffer "*Ivy Help*")) + (inhibit-read-only t)) + (unless buf + (setq buf (get-buffer-create "*Ivy Help*")) + (cl-letf (((symbol-function #'help-buffer) (lambda () buf))) + (describe-mode)) + (with-current-buffer buf + (goto-char (point-min)) + (insert "* describe-mode\n") + (goto-char (point-min)) + (insert-file-contents ivy-help-file) + (org-mode) + (setq-local org-hide-emphasis-markers t) + (view-mode) + (goto-char (point-min)) + (let ((inhibit-message t)) + (org-cycle '(64))))) + (if (eq this-command 'ivy-help) + (switch-to-buffer buf) + (with-ivy-window + (pop-to-buffer buf))) + (view-mode) + (goto-char (point-min)))) + +(declare-function ffap-url-p "ffap") +(defvar ffap-url-fetcher) + +(defun ivy-ffap-url-p (string) + "Forward to `ffap-url-p'." + (require 'ffap) + (ffap-url-p string)) + +(defun ivy-ffap-url-fetcher (url) + "Calls `ffap-url-fetcher'." + (require 'ffap) + (funcall ffap-url-fetcher url)) + +(ivy-configure 'read-file-name-internal + :sort-fn #'ivy-sort-file-function-default + :display-transformer-fn #'ivy-read-file-transformer + :alt-done-fn #'ivy--directory-done) + +(ivy-configure 'internal-complete-buffer + :display-transformer-fn #'ivy-switch-buffer-transformer) + +(ivy-configure 'Info-read-node-name-1 + :alt-done-fn #'ivy--info-alt-done) + +(provide 'ivy) + +;;; ivy.el ends here diff --git a/.emacs.d/lisp/multiple-cursors/mc-cycle-cursors.el b/.emacs.d/lisp/mc-cycle-cursors.el similarity index 100% rename from .emacs.d/lisp/multiple-cursors/mc-cycle-cursors.el rename to .emacs.d/lisp/mc-cycle-cursors.el diff --git a/.emacs.d/lisp/multiple-cursors/mc-edit-lines.el b/.emacs.d/lisp/mc-edit-lines.el similarity index 100% rename from .emacs.d/lisp/multiple-cursors/mc-edit-lines.el rename to .emacs.d/lisp/mc-edit-lines.el diff --git a/.emacs.d/lisp/multiple-cursors/mc-hide-unmatched-lines-mode.el b/.emacs.d/lisp/mc-hide-unmatched-lines-mode.el similarity index 100% rename from .emacs.d/lisp/multiple-cursors/mc-hide-unmatched-lines-mode.el rename to .emacs.d/lisp/mc-hide-unmatched-lines-mode.el diff --git a/.emacs.d/lisp/multiple-cursors/mc-mark-more.el b/.emacs.d/lisp/mc-mark-more.el similarity index 100% rename from .emacs.d/lisp/multiple-cursors/mc-mark-more.el rename to .emacs.d/lisp/mc-mark-more.el diff --git a/.emacs.d/lisp/multiple-cursors/mc-mark-pop.el b/.emacs.d/lisp/mc-mark-pop.el similarity index 100% rename from .emacs.d/lisp/multiple-cursors/mc-mark-pop.el rename to .emacs.d/lisp/mc-mark-pop.el diff --git a/.emacs.d/lisp/multiple-cursors/mc-separate-operations.el b/.emacs.d/lisp/mc-separate-operations.el similarity index 100% rename from .emacs.d/lisp/multiple-cursors/mc-separate-operations.el rename to .emacs.d/lisp/mc-separate-operations.el diff --git a/.emacs.d/lisp/multiple-cursors/multiple-cursors-core.el b/.emacs.d/lisp/multiple-cursors-core.el similarity index 100% rename from .emacs.d/lisp/multiple-cursors/multiple-cursors-core.el rename to .emacs.d/lisp/multiple-cursors-core.el diff --git a/.emacs.d/lisp/multiple-cursors/multiple-cursors.el b/.emacs.d/lisp/multiple-cursors.el similarity index 100% rename from .emacs.d/lisp/multiple-cursors/multiple-cursors.el rename to .emacs.d/lisp/multiple-cursors.el diff --git a/.emacs.d/lisp/popup.el b/.emacs.d/lisp/popup.el new file mode 100644 index 0000000..6c2f696 --- /dev/null +++ b/.emacs.d/lisp/popup.el @@ -0,0 +1,1459 @@ +;;; popup.el --- Visual Popup User Interface -*- lexical-binding: t; -*- + +;; Copyright (C) 2009-2015 Tomohiro Matsuyama +;; Copyright (c) 2020-2025 Jen-Chieh Shen + +;; Author: Tomohiro Matsuyama +;; Maintainer: Shen, Jen-Chieh +;; URL: https://github.com/auto-complete/popup-el +;; Keywords: lisp +;; Version: 0.5.9 +;; Package-Requires: ((emacs "24.3")) + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; popup.el is a visual popup user interface library for Emacs. This +;; provides a basic API and common UI widgets such as popup tooltips +;; and popup menus. +;; See README.markdown for more information. + +;;; Code: + +(require 'cl-lib) +(require 'mule) + +(defconst popup-version "0.5.9") + + + +;;; Utilities + +(defun popup-calculate-max-width (max-width) + "Determines whether the width with MAX-WIDTH desired is character or window +proportion based, And return the result." + (cl-typecase max-width + (integer max-width) + (float (* (ceiling (/ (round (* max-width (window-width))) 10.0)) 10)))) + +(defvar popup-use-optimized-column-computation t + "Use the optimized column computation routine. +If there is a problem, please set it nil.") + +(defmacro popup-aif (test then &rest else) + "Anaphoric if." + (declare (indent 2)) + `(let ((it ,test)) + (if it ,then ,@else))) + +(defmacro popup-awhen (test &rest body) + "Anaphoric when." + (declare (indent 1)) + `(let ((it ,test)) + (when it ,@body))) + +(defun popup-x-to-string (x) + "Convert any object to string efficiently. +This is faster than `prin1-to-string' in many cases." + (cl-typecase x + (string x) + (symbol (symbol-name x)) + (integer (number-to-string x)) + (float (number-to-string x)) + (t (format "%s" x)))) + +(defun popup-substring-by-width (string width) + "Return a cons cell of substring and remaining string by +splitting with WIDTH." + ;; Expand tabs into 4 spaces + (setq string (replace-regexp-in-string "\t" " " string)) + (cl-loop with len = (length string) + with w = 0 + for l from 0 + for c in (append string nil) + while (<= (cl-incf w (char-width c)) width) + finally return + (if (< l len) + (cons (substring string 0 l) (substring string l)) + (list string)))) + +(defun popup-fill-string (string &optional width max-width justify squeeze) + "Split STRING into fixed width strings and return a cons cell +like \(WIDTH . ROWS). Here, the car WIDTH indicates the actual +maxim width of ROWS. + +The argument WIDTH specifies the width of filling each +paragraph. WIDTH nil means don't perform any justification and +word wrap. Note that this function doesn't add any padding +characters at the end of each row. + +MAX-WIDTH, if WIDTH is nil, specifies the maximum number of +columns. + +The optional fourth argument JUSTIFY specifies which kind of +justification to do: `full', `left', `right', `center', or +`none' (equivalent to nil). A value of t means handle each +paragraph as specified by its text properties. + +SQUEEZE nil means leave whitespaces other than line breaks +untouched." + (if (eq width 0) + (error "Can't fill string with 0 width")) + (if width + (setq max-width width)) + (with-temp-buffer + (let ((tab-width 4) + (fill-column width) + (left-margin 0) + (kinsoku-limit 1) + indent-tabs-mode + row rows) + (insert string) + (untabify (point-min) (point-max)) + (if width + (fill-region (point-min) (point-max) justify (not squeeze))) + (goto-char (point-min)) + (setq width 0) + (while (prog2 + (let ((line (buffer-substring + (point) (progn (end-of-line) (point))))) + (if max-width + (while (progn + (setq row (truncate-string-to-width line max-width) + width (max width (string-width row))) + (push row rows) + (if (not (= (length row) (length line))) + (setq line (substring line (length row)))))) + (setq width (max width (string-width line))) + (push line rows))) + (< (point) (point-max)) + (beginning-of-line 2))) + (cons width (nreverse rows))))) + +(defmacro popup-save-buffer-state (&rest body) + (declare (indent 0)) + `(save-excursion + (let ((buffer-undo-list t) + (inhibit-read-only t) + (modified (buffer-modified-p))) + (unwind-protect + (progn ,@body) + (set-buffer-modified-p modified))))) + +(defun popup-vertical-motion (column direction) + "A portable version of `vertical-motion'." + (when (bound-and-true-p display-line-numbers-mode) + (setq column (- column (line-number-display-width 'columns)))) + (if (>= emacs-major-version 23) + (vertical-motion (cons column direction)) + (vertical-motion direction) + (move-to-column (+ (current-column) column)))) + +(defun popup-last-line-of-buffer-p () + "Return non-nil if the cursor is at the last line of the +buffer." + (save-excursion (end-of-line) (/= (forward-line) 0))) + +(defun popup-lookup-key-by-event (function event) + (or (funcall function (vector event)) + (if (symbolp event) + (popup-aif (get event 'event-symbol-element-mask) + (funcall function + (vector (logior (or (get (car it) 'ascii-character) + 0) + (cadr it)))))))) + + + +;;; Core + +(defgroup popup nil + "Visual Popup User Interface" + :group 'lisp + :prefix "popup-") + +(defface popup-face + '((t (:inherit default :background "lightgray" :foreground "black"))) + "Face for popup." + :group 'popup) + +(defface popup-summary-face + '((t (:inherit popup-face :foreground "dimgray"))) + "Face for popup summary." + :group 'popup) + +(defface popup-scroll-bar-foreground-face + '((t (:background "black"))) + "Foreground face for scroll-bar." + :group 'popup) + +(defface popup-scroll-bar-background-face + '((t (:background "gray"))) + "Background face for scroll-bar." + :group 'popup) + +(defvar popup-instances nil + "Popup instances.") + +(defvar popup-scroll-bar-foreground-char + (propertize " " 'face 'popup-scroll-bar-foreground-face) + "Foreground character for scroll-bar.") + +(defvar popup-scroll-bar-background-char + (propertize " " 'face 'popup-scroll-bar-background-face) + "Background character for scroll-bar.") + +(cl-defstruct popup + point row column width height min-height direction overlays keymap + parent depth + face mouse-face selection-face summary-face + margin-left margin-right margin-left-cancel scroll-bar symbol + cursor offset scroll-top current-height list newlines + pattern original-list invis-overlays) + +(defun popup-item-propertize (item &rest properties) + "Same as `propertize' except that this avoids overriding +existed value with `nil' property." + (cl-loop for (k v) on properties by 'cddr + if v append (list k v) into props + finally return + (apply 'propertize + (popup-x-to-string item) + props))) + +(defun popup-item-property (item property) + "Same as `get-text-property' except that this returns nil if +ITEM is not string." + (if (stringp item) + (get-text-property 0 property item))) + +(defun popup-replace-displayable (str &optional rep) + "Replace non-displayable character from STR. + +Optional argument REP is the replacement string of +non-displayable character." + (let ((rep (or rep "")) + (results (list))) + (dolist (string (split-string str "")) + (let* ((char (string-to-char string)) + (string (if (char-displayable-p char) + string + rep))) + (push string results))) + (string-join (reverse results)))) + +(cl-defun popup-make-item (name + &key + value + face + mouse-face + selection-face + sublist + document + symbol + summary) + "Utility function to make popup item. See also +`popup-item-propertize'." + (popup-item-propertize name + 'value value + 'popup-face face + 'popup-mouse-face mouse-face + 'selection-face selection-face + 'document document + 'symbol symbol + 'summary summary + 'sublist sublist)) + +(defsubst popup-item-value (item) (popup-item-property item 'value)) +(defsubst popup-item-value-or-self (item) (or (popup-item-value item) item)) +(defsubst popup-item-face (item) (popup-item-property item 'popup-face)) +(defsubst popup-item-mouse-face (item) (popup-item-property item 'popup-mouse-face)) +(defsubst popup-item-selection-face (item) (popup-item-property item 'selection-face)) +(defsubst popup-item-document (item) (popup-item-property item 'document)) +(defsubst popup-item-summary (item) (popup-item-property item 'summary)) +(defsubst popup-item-symbol (item) (popup-item-property item 'symbol)) +(defsubst popup-item-sublist (item) (popup-item-property item 'sublist)) + +(defun popup-item-documentation (item) + (let ((doc (popup-item-document item))) + (if (functionp doc) + (setq doc (funcall doc (popup-item-value-or-self item)))) + doc)) + +(defun popup-item-show-help-1 (item) + (let ((doc (popup-item-documentation item))) + (when doc + (with-current-buffer (get-buffer-create " *Popup Help*") + (erase-buffer) + (insert doc) + (goto-char (point-min)) + (display-buffer (current-buffer))) + t))) + +(defun popup-item-show-help-with-event-loop (item) + (save-window-excursion + (when (popup-item-show-help-1 item) + (cl-loop do (clear-this-command-keys) + for key = (read-key-sequence-vector nil) + do + (cl-case (key-binding key) + (scroll-other-window + (scroll-other-window)) + (scroll-other-window-down + (scroll-other-window-down nil)) + (otherwise + (setq unread-command-events (append key unread-command-events)) + (cl-return))))))) + +(defun popup-item-show-help (item &optional persist) + "Display the documentation of ITEM with `display-buffer'. If +PERSIST is nil, the documentation buffer will be closed +automatically, meaning interal event loop ensures the buffer to +be closed. Otherwise, the buffer will be just displayed as +usual." + (when item + (if (not persist) + (popup-item-show-help-with-event-loop item) + (popup-item-show-help-1 item)))) + +(defun popup-set-list (popup list) + (popup-set-filtered-list popup list) + (setf (popup-pattern popup) nil) + (setf (popup-original-list popup) list)) + +(defun popup-set-filtered-list (popup list) + (let ((offset + (if (> (popup-direction popup) 0) + 0 + (max (- (popup-height popup) (length list)) 0)))) + (setf (popup-list popup) list + (popup-offset popup) offset))) + +(defun popup-selected-item (popup) + (nth (popup-cursor popup) (popup-list popup))) + +(defun popup-selected-line (popup) + (- (popup-cursor popup) (popup-scroll-top popup))) + +(defun popup-line-overlay (popup line) + (aref (popup-overlays popup) line)) + +(defun popup-selected-line-overlay (popup) + (popup-line-overlay popup (popup-selected-line popup))) + +(defun popup-hide-line (popup line) + (let ((overlay (popup-line-overlay popup line))) + (overlay-put overlay 'display nil) + (overlay-put overlay 'after-string nil))) + +(defun popup-line-hidden-p (popup line) + (let ((overlay (popup-line-overlay popup line))) + (and (eq (overlay-get overlay 'display) nil) + (eq (overlay-get overlay 'after-string) nil)))) + +(cl-defun popup-set-line-item (popup + line + &key + item + face + mouse-face + margin-left + margin-right + scroll-bar-char + symbol + summary + summary-face + keymap) + (let* ((overlay (popup-line-overlay popup line)) + (content (popup-create-line-string popup (popup-x-to-string item) + :margin-left margin-left + :margin-right margin-right + :symbol symbol + :summary summary + :summary-face summary-face)) + (start 0) + (prefix (overlay-get overlay 'prefix)) + (postfix (overlay-get overlay 'postfix)) + end) + (put-text-property 0 (length content) 'popup-item item content) + (put-text-property 0 (length content) 'keymap keymap content) + ;; Overlap face properties + (when (get-text-property start 'face content) + (setq start (next-single-property-change start 'face content))) + (while (and start (setq end (next-single-property-change start 'face content))) + (put-text-property start end 'face face content) + (setq start (next-single-property-change end 'face content))) + (when start + (put-text-property start (length content) 'face face content)) + (when mouse-face + (put-text-property 0 (length content) 'mouse-face mouse-face content)) + (let ((prop (if (overlay-get overlay 'dangle) + 'after-string + 'display))) + (overlay-put overlay + prop + (concat prefix + content + scroll-bar-char + postfix))))) + +(cl-defun popup-create-line-string (popup + string + &key + margin-left + margin-right + symbol + summary + summary-face) + (let* ((popup-width (popup-width popup)) + (summary-width (string-width summary)) + (content-width (max + (min popup-width (string-width string)) + (- popup-width + (if (> summary-width 0) + (+ summary-width 2) + 0)))) + (string (car (popup-substring-by-width string content-width))) + (string-width (string-width string)) + (spacing (max (- popup-width string-width summary-width) + (if (> popup-width string-width) 1 0))) + (truncated-summary + (car (popup-substring-by-width + summary (max (- popup-width string-width spacing) 0))))) + (when summary-face + (put-text-property 0 (length truncated-summary) + 'face summary-face truncated-summary)) + (concat margin-left + string + (make-string spacing ? ) + truncated-summary + symbol + margin-right))) + +(defun popup-live-p (popup) + "Return non-nil if POPUP is alive." + (and popup (popup-overlays popup) t)) + +(defun popup-child-point (popup &optional offset) + (overlay-end + (popup-line-overlay + popup + (or offset + (popup-selected-line popup))))) + +(defun popup-calculate-direction (height row) + "Return a proper direction when displaying a popup on this +window. HEIGHT is the a height of the popup, and ROW is a line +number at the point." + (let* ((remaining-rows (- (max 1 (- (window-text-height) + (if mode-line-format 1 0) + (if header-line-format 1 0))) + (count-lines (window-start) (point)))) + (enough-space-above (> row height)) + (enough-space-below (<= height remaining-rows))) + (if (and enough-space-above + (not enough-space-below)) + -1 + 1))) + +(cl-defun popup-create (point + width + height + &key + min-height + max-width + around + (face 'popup-face) + mouse-face + (selection-face face) + (summary-face 'popup-summary-face) + scroll-bar + margin-left + margin-right + symbol + parent + parent-offset + keymap) + "Create a popup instance at POINT with WIDTH and HEIGHT. + +MIN-HEIGHT is a minimal height of the popup. The default value is +0. + +MAX-WIDTH is the maximum width of the popup. The default value is +nil (no limit). If a floating point, the value refers to the ratio of +the window. If an integer, limit is in characters. + +If AROUND is non-nil, the popup will be displayed around the +point but not at the point. + +FACE is a background face of the popup. The default value is POPUP-FACE. + +SELECTION-FACE is a foreground (selection) face of the popup The +default value is POPUP-FACE. + +If SCROLL-BAR is non-nil, the popup will have a scroll bar at the +right. + +If MARGIN-LEFT is non-nil, the popup will have a margin at the +left. + +If MARGIN-RIGHT is non-nil, the popup will have a margin at the +right. + +SYMBOL is a single character which indicates a kind of the item. + +PARENT is a parent popup instance. If PARENT is omitted, the +popup will be a root instance. + +PARENT-OFFSET is a row offset from the parent popup. + +KEYMAP is a keymap that will be put on the popup contents." + (or margin-left (setq margin-left 0)) + (or margin-right (setq margin-right 0)) + (unless point + (setq point + (if parent (popup-child-point parent parent-offset) (point)))) + (when max-width + (setq width (min width (popup-calculate-max-width max-width)))) + (save-excursion + (goto-char point) + (let* ((col-row (posn-col-row (posn-at-point))) + (row (cdr col-row)) + (column (car col-row)) + (overlays (make-vector height nil)) + (popup-width (+ width + (if scroll-bar 1 0) + margin-left + margin-right + (if symbol 2 0))) + margin-left-cancel + (window (selected-window)) + (window-start (window-start)) + (window-hscroll (window-hscroll)) + (window-width (window-width)) + (right (+ column popup-width)) + (overflow (and (> right window-width) + (>= right popup-width))) + (foldable (and (null parent) + (>= column popup-width))) + (direction (or + ;; Currently the direction of cascade popup won't be changed + (and parent (popup-direction parent)) + + ;; Calculate direction + (popup-calculate-direction height row))) + (depth (if parent (1+ (popup-depth parent)) 0)) + (newlines (max 0 (+ (- height (count-lines point (point-max))) (if around 1 0)))) + invis-overlays + current-column) + ;; Case: no newlines at the end of the buffer + (when (> newlines 0) + (popup-save-buffer-state + (goto-char (point-max)) + (insert (make-string newlines ?\n)))) + + ;; Case: the popup overflows + (if overflow + (if foldable + (progn + (cl-decf column (- popup-width margin-left margin-right)) + (unless around (move-to-column column))) + (when (not truncate-lines) + ;; Truncate. + (let ((d (1+ (- popup-width (- window-width column))))) + (cl-decf popup-width d) + (cl-decf width d))) + (cl-decf column margin-left)) + (cl-decf column margin-left)) + + ;; Case: no space at the left + (when (and (null parent) + (< column 0)) + ;; Cancel margin left + (setq column 0) + (cl-decf popup-width margin-left) + (setq margin-left-cancel t)) + + (dotimes (i height) + (let (overlay begin w (dangle t) (prefix "") (postfix "")) + (when around + (popup-vertical-motion column direction)) + (cl-loop for ov in (overlays-in (save-excursion + (beginning-of-visual-line) + (point)) + (save-excursion + (end-of-visual-line) + (point))) + when (and (not (overlay-get ov 'popup)) + (not (overlay-get ov 'popup-item)) + (or (overlay-get ov 'invisible) + (overlay-get ov 'display))) + do (progn + (push (list ov (overlay-get ov 'display)) invis-overlays) + (overlay-put ov 'display ""))) + (setq around t) + (setq current-column (car (posn-col-row (posn-at-point)))) + + (when (< current-column column) + ;; Extend short buffer lines by popup prefix (line of spaces) + (setq prefix (make-string + (+ (if (= current-column 0) + (- window-hscroll current-column) + 0) + (- column current-column)) + ? ))) + + (setq begin (point)) + (setq w (+ popup-width (length prefix))) + (while (and (not (eolp)) (> w 0)) + (setq dangle nil) + (cl-decf w (char-width (char-after))) + (forward-char)) + (if (< w 0) + (setq postfix (make-string (- w) ? ))) + + (setq overlay (make-overlay begin (point))) + (overlay-put overlay 'popup t) + (overlay-put overlay 'window window) + (overlay-put overlay 'dangle dangle) + (overlay-put overlay 'prefix prefix) + (overlay-put overlay 'postfix postfix) + (overlay-put overlay 'width width) + (aset overlays + (if (> direction 0) i (- height i 1)) + overlay))) + (cl-loop for p from (- 10000 (* depth 1000)) + for overlay in (nreverse (append overlays nil)) + do (overlay-put overlay 'priority p)) + (let ((it (make-popup :point point + :row row + :column column + :width width + :height height + :min-height min-height + :direction direction + :parent parent + :depth depth + :face face + :mouse-face mouse-face + :selection-face selection-face + :summary-face summary-face + :margin-left margin-left + :margin-right margin-right + :margin-left-cancel margin-left-cancel + :scroll-bar scroll-bar + :symbol symbol + :cursor 0 + :offset 0 + :scroll-top 0 + :current-height 0 + :list nil + :newlines newlines + :overlays overlays + :invis-overlays invis-overlays + :keymap keymap))) + (push it popup-instances) + it)))) + +(defun popup-delete (popup) + "Delete POPUP instance." + (when (popup-live-p popup) + (popup-hide popup) + (mapc 'delete-overlay (popup-overlays popup)) + (setf (popup-overlays popup) nil) + (setq popup-instances (delq popup popup-instances)) + ;; Restore newlines state + (let ((newlines (popup-newlines popup))) + (when (> newlines 0) + (popup-save-buffer-state + (goto-char (point-max)) + (dotimes (i newlines) + (if (and (char-before) + (= (char-before) ?\n)) + (delete-char -1))))))) + nil) + +(defun popup-draw (popup) + "Draw POPUP." + (cl-loop for (ov olddisplay) in (popup-invis-overlays popup) + do (overlay-put ov 'display "")) + + (cl-loop with height = (popup-height popup) + with min-height = (popup-min-height popup) + with popup-face = (popup-face popup) + with mouse-face = (popup-mouse-face popup) + with selection-face = (popup-selection-face popup) + with summary-face-0 = (popup-summary-face popup) + with list = (popup-list popup) + with length = (length list) + with thum-size = (max (/ (* height height) (max length 1)) 1) + with page-size = (/ (+ 0.0 (max length 1)) height) + with scroll-bar = (popup-scroll-bar popup) + with margin-left = (make-string (if (popup-margin-left-cancel popup) 0 (popup-margin-left popup)) ? ) + with margin-right = (make-string (popup-margin-right popup) ? ) + with symbol = (popup-symbol popup) + with cursor = (popup-cursor popup) + with scroll-top = (popup-scroll-top popup) + with offset = (popup-offset popup) + with keymap = (popup-keymap popup) + for o from offset + for i from scroll-top + while (< o height) + for item in (nthcdr scroll-top list) + for page-index = (* thum-size (/ o thum-size)) + for face = (if (= i cursor) + (or (popup-item-selection-face item) selection-face) + (or (popup-item-face item) popup-face)) + for summary-face = (unless (= i cursor) summary-face-0) + for empty-char = (propertize " " 'face face) + for scroll-bar-char = (if scroll-bar + (cond + ((and (not (eq scroll-bar :always)) + (<= page-size 1)) + empty-char) + ((and (> page-size 1) + (>= cursor (* page-index page-size)) + (< cursor (* (+ page-index thum-size) page-size))) + popup-scroll-bar-foreground-char) + (t + popup-scroll-bar-background-char)) + "") + for sym = (if symbol + (concat " " (or (popup-item-symbol item) " ")) + "") + for summary = (or (popup-item-summary item) "") + + do + ;; Show line and set item to the line + (popup-set-line-item popup o + :item item + :face face + :mouse-face mouse-face + :margin-left margin-left + :margin-right margin-right + :scroll-bar-char scroll-bar-char + :symbol sym + :summary summary + :summary-face summary-face + :keymap keymap) + + finally + ;; Remember current height + (setf (popup-current-height popup) (- o offset)) + + ;; Hide remaining lines + (let ((scroll-bar-char (if scroll-bar (propertize " " 'face popup-face) "")) + (symbol (if symbol " " ""))) + (if (> (popup-direction popup) 0) + (progn + (when min-height + (while (< o min-height) + (popup-set-line-item popup o + :item "" + :face popup-face + :margin-left margin-left + :margin-right margin-right + :scroll-bar-char scroll-bar-char + :symbol symbol + :summary "") + (cl-incf o))) + (while (< o height) + (popup-hide-line popup o) + (cl-incf o))) + (cl-loop with h = (if min-height (- height min-height) offset) + for o from 0 below offset + if (< o h) + do (popup-hide-line popup o) + if (>= o h) + do (popup-set-line-item popup o + :item "" + :face popup-face + :margin-left margin-left + :margin-right margin-right + :scroll-bar-char scroll-bar-char + :symbol symbol + :summary "")))))) + +(defun popup-hide (popup) + "Hide POPUP." + (cl-loop for (ov olddisplay) in (popup-invis-overlays popup) + do (overlay-put ov 'display olddisplay)) + (dotimes (i (popup-height popup)) + (popup-hide-line popup i))) + +(defun popup-hidden-p (popup) + "Return non-nil if POPUP is hidden." + (let ((hidden t)) + (when (popup-live-p popup) + (dotimes (i (popup-height popup)) + (unless (popup-line-hidden-p popup i) + (setq hidden nil)))) + hidden)) + +(defun popup-jump (popup cursor) + "Jump to a position specified by CURSOR of POPUP and draw." + (let ((scroll-top (popup-scroll-top popup))) + ;; Do not change page as much as possible. + (unless (and (<= scroll-top cursor) + (< cursor (+ scroll-top (popup-height popup)))) + (setf (popup-scroll-top popup) cursor)) + (setf (popup-cursor popup) cursor) + (popup-draw popup))) + +(defun popup-select (popup i) + "Select the item at I of POPUP and draw." + (setq i (+ i (popup-offset popup))) + (when (and (<= 0 i) (< i (popup-height popup))) + (setf (popup-cursor popup) i) + (popup-draw popup) + t)) + +(defun popup-next (popup) + "Select the next item of POPUP and draw." + (let ((height (popup-height popup)) + (cursor (1+ (popup-cursor popup))) + (scroll-top (popup-scroll-top popup)) + (length (length (popup-list popup)))) + (cond + ((>= cursor length) + ;; Back to first page + (setq cursor 0 + scroll-top 0)) + ((= cursor (+ scroll-top height)) + ;; Go to next page + (setq scroll-top (min (1+ scroll-top) (max (- length height) 0))))) + (setf (popup-cursor popup) cursor + (popup-scroll-top popup) scroll-top) + (popup-draw popup))) + +(defun popup-previous (popup) + "Select the previous item of POPUP and draw." + (let ((height (popup-height popup)) + (cursor (1- (popup-cursor popup))) + (scroll-top (popup-scroll-top popup)) + (length (length (popup-list popup)))) + (cond + ((< cursor 0) + ;; Go to last page + (setq cursor (1- length) + scroll-top (max (- length height) 0))) + ((= cursor (1- scroll-top)) + ;; Go to previous page + (cl-decf scroll-top))) + (setf (popup-cursor popup) cursor + (popup-scroll-top popup) scroll-top) + (popup-draw popup))) + +(defun popup-page-next (popup) + "Select next item of POPUP per `popup-height' range. +Pages down through POPUP." + (dotimes (counter (1- (popup-height popup))) + (popup-next popup))) + +(defun popup-page-previous (popup) + "Select previous item of POPUP per `popup-height' range. +Pages up through POPUP." + (dotimes (counter (1- (popup-height popup))) + (popup-previous popup))) + +(defun popup-scroll-down (popup &optional n) + "Scroll down N of POPUP and draw." + (let ((scroll-top (min (+ (popup-scroll-top popup) (or n 1)) + (- (length (popup-list popup)) (popup-height popup))))) + (setf (popup-cursor popup) scroll-top + (popup-scroll-top popup) scroll-top) + (popup-draw popup))) + +(defun popup-scroll-up (popup &optional n) + "Scroll up N of POPUP and draw." + (let ((scroll-top (max (- (popup-scroll-top popup) (or n 1)) + 0))) + (setf (popup-cursor popup) scroll-top + (popup-scroll-top popup) scroll-top) + (popup-draw popup))) + + + +;;; Popup Incremental Search + +(defface popup-isearch-match + '((t (:inherit default :background "sky blue"))) + "Popup isearch match face." + :group 'popup) + +(defvar popup-isearch-cursor-color "blue") + +(defvar popup-isearch-keymap + (let ((map (make-sparse-keymap))) + ;;(define-key map "\r" 'popup-isearch-done) + (define-key map "\C-g" 'popup-isearch-cancel) + (define-key map "\C-b" 'popup-isearch-close) + (define-key map [left] 'popup-isearch-close) + (define-key map "\C-h" 'popup-isearch-delete) + (define-key map (kbd "DEL") 'popup-isearch-delete) + (define-key map (kbd "C-y") 'popup-isearch-yank) + map)) + +(defvar popup-menu-show-quick-help-function 'popup-menu-show-quick-help + "Function used for showing quick help by `popup-menu*'.") + +(defcustom popup-isearch-regexp-builder-function #'regexp-quote + "Function used to construct a regexp from a pattern. You may for instance + provide a function that replaces spaces by '.+' if you like helm or ivy style + of completion." + :type 'function) + +(defsubst popup-isearch-char-p (char) + (and (integerp char) + (<= 32 char) + (<= char 126))) + +(defun popup-isearch-filter-list (pattern list) + (cl-loop with regexp = (funcall popup-isearch-regexp-builder-function pattern) + for item in list + do + (unless (stringp item) + (setq item (popup-item-propertize (popup-x-to-string item) + 'value item))) + if (string-match regexp item) + collect + (let ((beg (match-beginning 0)) + (end (match-end 0))) + (alter-text-property 0 (length item) 'face + (lambda (prop) + (unless (eq prop 'popup-isearch-match) + prop)) + item) + (put-text-property beg end + 'face 'popup-isearch-match + item) + item))) + +(defun popup-isearch-prompt (popup pattern) + (format "Pattern: %s" (if (= (length (popup-list popup)) 0) + (propertize pattern 'face 'isearch-fail) + pattern))) + +(defun popup-isearch-update (popup filter pattern &optional callback) + (setf (popup-cursor popup) 0 + (popup-scroll-top popup) 0 + (popup-pattern popup) pattern) + (let ((list (funcall filter pattern (popup-original-list popup)))) + (popup-set-filtered-list popup list) + (if callback + (funcall callback list))) + (popup-draw popup)) + +(cl-defun popup-isearch (popup + &key + (filter 'popup-isearch-filter-list) + (cursor-color popup-isearch-cursor-color) + (keymap popup-isearch-keymap) + callback + help-delay) + "Start isearch on POPUP. This function is synchronized, meaning +event loop waits for quiting of isearch. + +FILTER is function with two argumenst to perform popup items filtering. + +CURSOR-COLOR is a cursor color during isearch. The default value +is `popup-isearch-cursor-color'. + +KEYMAP is a keymap which is used when processing events during +event loop. The default value is `popup-isearch-keymap'. + +CALLBACK is a function taking one argument. `popup-isearch' calls +CALLBACK, if specified, after isearch finished or isearch +canceled. The arguments is whole filtered list of items. + +HELP-DELAY is a delay of displaying helps." + (let ((list (popup-original-list popup)) + (pattern (or (popup-pattern popup) "")) + (old-cursor-color (frame-parameter (selected-frame) 'cursor-color)) + prompt key binding) + (unwind-protect + (cl-block nil + (if cursor-color + (set-cursor-color cursor-color)) + (while t + (setq prompt (popup-isearch-prompt popup pattern)) + (setq key (popup-menu-read-key-sequence keymap prompt help-delay)) + (if (null key) + (unless (funcall popup-menu-show-quick-help-function popup nil :prompt prompt) + (clear-this-command-keys) + (push (read-event prompt) unread-command-events)) + (setq binding (lookup-key keymap key)) + (cond + ((and (stringp key) + (popup-isearch-char-p (aref key 0))) + (setq pattern (concat pattern key))) + ((eq binding 'popup-isearch-done) + (cl-return nil)) + ((eq binding 'popup-isearch-cancel) + (popup-isearch-update popup filter "" callback) + (cl-return t)) + ((eq binding 'popup-isearch-close) + (popup-isearch-update popup filter "" callback) + (setq unread-command-events + (append (listify-key-sequence key) unread-command-events)) + (cl-return nil)) + ((eq binding 'popup-isearch-delete) + (if (> (length pattern) 0) + (setq pattern (substring pattern 0 (1- (length pattern)))))) + ((eq binding 'popup-isearch-yank) + (popup-isearch-update popup filter (car kill-ring) callback) + (cl-return nil)) + (t + (setq unread-command-events + (append (listify-key-sequence key) unread-command-events)) + (cl-return nil))) + (popup-isearch-update popup filter pattern callback)))) + (if old-cursor-color + (set-cursor-color old-cursor-color))))) + + + +;;; Popup Tip + +(defface popup-tip-face + '((t (:background "khaki1" :foreground "black"))) + "Face for popup tip." + :group 'popup) + +(defvar popup-tip-max-width 80) + +(cl-defun popup-tip (string + &key + point + (around t) + width + (height 15) + min-height + max-width + truncate + margin + margin-left + margin-right + scroll-bar + parent + parent-offset + nowait + nostrip + prompt + face + &allow-other-keys + &aux tip lines) + "Show a tooltip of STRING at POINT. This function is +synchronized unless NOWAIT specified. Almost all arguments are +the same as in `popup-create', except for TRUNCATE, NOWAIT, and +PROMPT. + +If TRUNCATE is non-nil, the tooltip can be truncated. + +If NOWAIT is non-nil, this function immediately returns the +tooltip instance without entering event loop. + +If `NOSTRIP` is non-nil, `STRING` properties are not stripped. + +PROMPT is a prompt string when reading events during event loop. + +If FACE is non-nil, it will be used instead of face `popup-tip-face'." + (if (bufferp string) + (setq string (with-current-buffer string (buffer-string)))) + + (unless nostrip + ;; TODO strip text (mainly face) properties + (setq string (substring-no-properties string))) + + (setq string (popup-replace-displayable string)) + + (and (eq margin t) (setq margin 1)) + (or margin-left (setq margin-left margin)) + (or margin-right (setq margin-right margin)) + + (let ((it (popup-fill-string string width popup-tip-max-width))) + (setq width (car it) + lines (cdr it))) + + (setq tip (popup-create point width height + :min-height min-height + :max-width max-width + :around around + :margin-left margin-left + :margin-right margin-right + :scroll-bar scroll-bar + :face (or face 'popup-tip-face) + :parent parent + :parent-offset parent-offset)) + + (unwind-protect + (when (> (popup-width tip) 0) ; not to be corrupted + (when (and (not (eq width (popup-width tip))) ; truncated + (not truncate)) + ;; Refill once again to lines be fitted to popup width + (setq width (popup-width tip)) + (setq lines (cdr (popup-fill-string string width width)))) + + (popup-set-list tip lines) + (popup-draw tip) + (if nowait + tip + (clear-this-command-keys) + (push (read-event prompt) unread-command-events) + t)) + (unless nowait + (popup-delete tip)))) + + + +;;; Popup Menu + +(defface popup-menu-face + '((t (:inherit popup-face))) + "Face for popup menu." + :group 'popup) + +(defface popup-menu-mouse-face + '((t (:background "blue" :foreground "white"))) + "Face for popup menu." + :group 'popup) + +(defface popup-menu-selection-face + '((t (:inherit default :background "steelblue" :foreground "white"))) + "Face for popup menu selection." + :group 'popup) + +(defface popup-menu-summary-face + '((t (:inherit popup-summary-face))) + "Face for popup summary." + :group 'popup) + +(defvar popup-menu-show-tip-function 'popup-tip + "Function used for showing tooltip by `popup-menu-show-quick-help'.") + +(defun popup-menu-show-help (menu &optional persist item) + (popup-item-show-help (or item (popup-selected-item menu)) persist)) + +(defun popup-menu-documentation (menu &optional item) + (popup-item-documentation (or item (popup-selected-item menu)))) + +(defun popup-menu-show-quick-help (menu &optional item &rest args) + (let* ((point (plist-get args :point)) + (height (or (plist-get args :height) (popup-height menu))) + (min-height (min height (popup-current-height menu))) + (around nil) + (parent-offset (popup-offset menu)) + (doc (popup-menu-documentation menu item))) + (when (stringp doc) + (if (popup-hidden-p menu) + (setq around t + menu nil + parent-offset nil) + (setq point nil)) + (let ((popup-use-optimized-column-computation nil)) ; To avoid wrong positioning + (apply popup-menu-show-tip-function + doc + :point point + :height height + :min-height min-height + :around around + :parent menu + :parent-offset parent-offset + args))))) + +(defun popup-menu-item-of-mouse-event (event) + (when (and (consp event) + (memq (cl-first event) '(mouse-1 mouse-2 mouse-3 mouse-4 mouse-5))) + (let* ((position (cl-second event)) + (object (elt position 4))) + (when (consp object) + (get-text-property (cdr object) 'popup-item (car object)))))) + +(defun popup-menu-read-key-sequence (keymap &optional prompt timeout) + (catch 'timeout + (let ((timer (and timeout + (run-with-timer timeout nil + (lambda () + (if (zerop (length (this-command-keys))) + (throw 'timeout nil)))))) + (old-global-map (current-global-map)) + (temp-global-map (make-sparse-keymap)) + (overriding-terminal-local-map (make-sparse-keymap))) + (substitute-key-definition 'keyboard-quit 'keyboard-quit + temp-global-map old-global-map) + (define-key temp-global-map [menu-bar] (lookup-key old-global-map [menu-bar])) + (define-key temp-global-map [tool-bar] (lookup-key old-global-map [tool-bar])) + (set-keymap-parent overriding-terminal-local-map keymap) + (if (current-local-map) + (define-key overriding-terminal-local-map [menu-bar] + (lookup-key (current-local-map) [menu-bar]))) + (unwind-protect + (progn + (use-global-map temp-global-map) + (clear-this-command-keys) + (with-temp-message prompt + (read-key-sequence nil))) + (use-global-map old-global-map) + (if timer (cancel-timer timer)))))) + +(defun popup-menu-fallback (event default)) + +(cl-defun popup-menu-event-loop (menu + keymap + fallback + &key + prompt + help-delay + isearch + isearch-filter + isearch-cursor-color + isearch-keymap + isearch-callback + &aux key binding) + (cl-block nil + (while (popup-live-p menu) + (and isearch + (popup-isearch menu + :filter isearch-filter + :cursor-color isearch-cursor-color + :keymap isearch-keymap + :callback isearch-callback + :help-delay help-delay) + (keyboard-quit)) + (setq key (popup-menu-read-key-sequence keymap prompt help-delay)) + (setq binding (and key (lookup-key keymap key))) + (cond + ((or (null key) (zerop (length key))) + (unless (funcall popup-menu-show-quick-help-function menu nil :prompt prompt) + (clear-this-command-keys) + (push (read-event prompt) unread-command-events))) + ((eq (lookup-key (current-global-map) key) 'keyboard-quit) + (keyboard-quit) + (cl-return)) + ((eq binding 'popup-close) + (if (popup-parent menu) + (cl-return))) + ((memq binding '(popup-select popup-open)) + (let* ((item (or (popup-menu-item-of-mouse-event (elt key 0)) + (popup-selected-item menu))) + (index (cl-position item (popup-list menu))) + (sublist (popup-item-sublist item))) + (unless index (cl-return)) + (if sublist + (popup-aif (let (popup-use-optimized-column-computation) + (popup-cascade-menu sublist + :around nil + :margin-left (popup-margin-left menu) + :margin-right (popup-margin-right menu) + :scroll-bar (popup-scroll-bar menu) + :parent menu + :parent-offset index + :help-delay help-delay + :isearch isearch + :isearch-filter isearch-filter + :isearch-cursor-color isearch-cursor-color + :isearch-keymap isearch-keymap + :isearch-callback isearch-callback)) + (and it (cl-return it))) + (if (eq binding 'popup-select) + (cl-return (popup-item-value-or-self item)))))) + ((eq binding 'popup-next) + (popup-next menu)) + ((eq binding 'popup-previous) + (popup-previous menu)) + ((eq binding 'popup-page-next) + (popup-page-next menu)) + ((eq binding 'popup-page-previous) + (popup-page-previous menu)) + ((eq binding 'popup-help) + (popup-menu-show-help menu)) + ((eq binding 'popup-isearch) + (popup-isearch menu + :filter isearch-filter + :cursor-color isearch-cursor-color + :keymap isearch-keymap + :callback isearch-callback + :help-delay help-delay)) + ((commandp binding) + (call-interactively binding)) + (t + (funcall fallback key (key-binding key))))))) + +(defun popup-preferred-width (list) + "Return the preferred width to show LIST beautifully." + (cl-loop with tab-width = 4 + for item in list + for summary = (popup-item-summary item) + maximize (string-width (popup-x-to-string item)) into width + if (stringp summary) + maximize (+ (string-width summary) 2) into summary-width + finally return + (let ((total (+ (or width 0) (or summary-width 0)))) + (* (ceiling (/ total 10.0)) 10)))) + +(defvar popup-menu-keymap + (let ((map (make-sparse-keymap))) + (define-key map "\r" 'popup-select) + (define-key map "\C-f" 'popup-open) + (define-key map [right] 'popup-open) + (define-key map "\C-b" 'popup-close) + (define-key map [left] 'popup-close) + + (define-key map "\C-n" 'popup-next) + (define-key map [down] 'popup-next) + (define-key map "\C-p" 'popup-previous) + (define-key map [up] 'popup-previous) + + (define-key map [next] 'popup-page-next) + (define-key map [prior] 'popup-page-previous) + + (define-key map [f1] 'popup-help) + (define-key map (kbd "\C-?") 'popup-help) + + (define-key map "\C-s" 'popup-isearch) + + (define-key map [mouse-1] 'popup-select) + (define-key map [mouse-4] 'popup-previous) + (define-key map [mouse-5] 'popup-next) + map)) + +(cl-defun popup-menu* (list + &key + point + (around t) + (width (popup-preferred-width list)) + (height 15) + max-width + margin + margin-left + margin-right + scroll-bar + symbol + parent + parent-offset + cursor + (keymap popup-menu-keymap) + (fallback 'popup-menu-fallback) + help-delay + nowait + prompt + isearch + (isearch-filter 'popup-isearch-filter-list) + (isearch-cursor-color popup-isearch-cursor-color) + (isearch-keymap popup-isearch-keymap) + isearch-callback + initial-index + &allow-other-keys + &aux menu event) + "Show a popup menu of LIST at POINT. This function returns a +value of the selected item. Almost all arguments are the same as in +`popup-create', except for KEYMAP, FALLBACK, HELP-DELAY, PROMPT, +ISEARCH, ISEARCH-FILTER, ISEARCH-CURSOR-COLOR, ISEARCH-KEYMAP, and +ISEARCH-CALLBACK. + +If KEYMAP is a keymap which is used when processing events during +event loop. + +If FALLBACK is a function taking two arguments; a key and a +command. FALLBACK is called when no special operation is found on +the key. The default value is `popup-menu-fallback', which does +nothing. + +HELP-DELAY is a delay of displaying helps. + +If NOWAIT is non-nil, this function immediately returns the menu +instance without entering event loop. + +PROMPT is a prompt string when reading events during event loop. + +If ISEARCH is non-nil, do isearch as soon as displaying the popup +menu. + +ISEARCH-FILTER is a filtering function taking two arguments: +search pattern and list of items. Returns a list of matching items. + +ISEARCH-CURSOR-COLOR is a cursor color during isearch. The +default value is `popup-isearch-cursor-color'. + +ISEARCH-KEYMAP is a keymap which is used when processing events +during event loop. The default value is `popup-isearch-keymap'. + +ISEARCH-CALLBACK is a function taking one argument. `popup-menu' +calls ISEARCH-CALLBACK, if specified, after isearch finished or +isearch canceled. The arguments is whole filtered list of items. + +If `INITIAL-INDEX' is non-nil, this is an initial index value for +`popup-select'. Only positive integer is valid." + (and (eq margin t) (setq margin 1)) + (or margin-left (setq margin-left margin)) + (or margin-right (setq margin-right margin)) + (if (and scroll-bar + (integerp margin-right) + (> margin-right 0)) + ;; Make scroll-bar space as margin-right + (cl-decf margin-right)) + (setq menu (popup-create point width height + :max-width max-width + :around around + :face 'popup-menu-face + :mouse-face 'popup-menu-mouse-face + :selection-face 'popup-menu-selection-face + :summary-face 'popup-menu-summary-face + :margin-left margin-left + :margin-right margin-right + :scroll-bar scroll-bar + :symbol symbol + :parent parent + :parent-offset parent-offset)) + (unwind-protect + (progn + (popup-set-list menu list) + (if cursor + (popup-jump menu cursor) + (popup-draw menu)) + (when initial-index + (dotimes (_i (min (- (length list) 1) initial-index)) + (popup-next menu))) + (if nowait + menu + (popup-menu-event-loop menu keymap fallback + :prompt prompt + :help-delay help-delay + :isearch isearch + :isearch-filter isearch-filter + :isearch-cursor-color isearch-cursor-color + :isearch-keymap isearch-keymap + :isearch-callback isearch-callback))) + (unless nowait + (popup-delete menu)))) + +(defun popup-cascade-menu (list &rest args) + "Same as `popup-menu' except that an element of LIST can be +also a sub-menu if the element is a cons cell formed (ITEM +. SUBLIST) where ITEM is an usual item and SUBLIST is a list of +the sub menu." + (apply 'popup-menu* + (mapcar (lambda (item) + (if (consp item) + (popup-make-item (car item) + :sublist (cdr item) + :symbol ">") + item)) + list) + :symbol t + args)) + +(provide 'popup) +;;; popup.el ends here diff --git a/.emacs.d/lisp/queue.el b/.emacs.d/lisp/queue.el new file mode 100644 index 0000000..4e173b3 --- /dev/null +++ b/.emacs.d/lisp/queue.el @@ -0,0 +1,165 @@ +;;; queue.el --- Queue data structure -*- lexical-binding: t; -*- + +;; Copyright (C) 1991-1995, 2008-2009, 2012, 2017 Free Software Foundation, Inc + +;; Author: Inge Wallin +;; Toby Cubitt +;; Maintainer: Toby Cubitt +;; Version: 0.2 +;; Keywords: extensions, data structures, queue +;; URL: http://www.dr-qubit.org/emacs.php +;; Repository: http://www.dr-qubit.org/git/predictive.git + +;; This file is part of Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify it under +;; the terms of the GNU General Public License as published by the Free +;; Software Foundation, either version 3 of the License, or (at your option) +;; any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for +;; more details. +;; +;; You should have received a copy of the GNU General Public License along +;; with GNU Emacs. If not, see . + + +;;; Commentary: +;; +;; These queues can be used both as a first-in last-out (FILO) and as a +;; first-in first-out (FIFO) stack, i.e. elements can be added to the front or +;; back of the queue, and can be removed from the front. (This type of data +;; structure is sometimes called an "output-restricted deque".) +;; +;; You create a queue using `make-queue', add an element to the end of the +;; queue using `queue-enqueue', and push an element onto the front of the +;; queue using `queue-prepend'. To remove the first element from a queue, use +;; `queue-dequeue'. A number of other queue convenience functions are also +;; provided, all starting with the prefix `queue-'. Functions with prefix +;; `queue--' are for internal use only, and should never be used outside this +;; package. + + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defmacro queue--when-generators (then) + "Evaluate THEN if `generator' library is available." + (declare (debug t)) + (if (require 'generator nil 'noerror) then)) + + +(defstruct (queue + ;; A tagged list is the pre-defstruct representation. + ;; (:type list) + :named + (:constructor nil) + (:constructor queue-create ()) + (:copier nil)) + head tail) + + +;;;###autoload +(defalias 'make-queue 'queue-create + "Create an empty queue data structure.") + + +(defun queue-enqueue (queue element) + "Append an ELEMENT to the end of the QUEUE." + (if (queue-head queue) + (setcdr (queue-tail queue) + (setf (queue-tail queue) (cons element nil))) + (setf (queue-head queue) + (setf (queue-tail queue) (cons element nil))))) + +(defalias 'queue-append 'queue-enqueue) + + +(defun queue-prepend (queue element) + "Prepend an ELEMENT to the front of the QUEUE." + (if (queue-head queue) + (push element (queue-head queue)) + (setf (queue-head queue) + (setf (queue-tail queue) (cons element nil))))) + + +(defun queue-dequeue (queue) + "Remove the first element of QUEUE and return it. +Returns nil if the queue is empty." + (unless (cdr (queue-head queue)) (setf (queue-tail queue) nil)) + (pop (queue-head queue))) + + +(defun queue-empty (queue) + "Return t if QUEUE is empty, otherwise return nil." + (null (queue-head queue))) + + +(defun queue-first (queue) + "Return the first element of QUEUE or nil if it is empty, +without removing it from the QUEUE." + (car (queue-head queue))) + + +(defun queue-nth (queue n) + "Return the nth element of a queue, without removing it. +If the length of the queue is less than N, return nil. The first +element in the queue has index 0." + (nth n (queue-head queue))) + + +(defun queue-last (queue) + "Return the last element of QUEUE, without removing it. +Returns nil if the QUEUE is empty." + (car (queue-tail queue))) + + +(defun queue-all (queue) + "Return a list of all elements of QUEUE or nil if it is empty. +The oldest element in the queue is the first in the list." + (queue-head queue)) + + +(defun queue-copy (queue) + "Return a copy of QUEUE. +The new queue contains the elements of QUEUE in the same +order. The elements themselves are *not* copied." + (let ((q (queue-create)) + (list (queue-head queue))) + (when (queue-head queue) + (setf (queue-head q) (cons (car (queue-head queue)) nil) + (queue-tail q) (queue-head q)) + (while (setq list (cdr list)) + (setf (queue-tail q) + (setcdr (queue-tail q) (cons (car list) nil))))) + q)) + + +(defun queue-length (queue) + "Return the number of elements in QUEUE." + (length (queue-head queue))) + + +(defun queue-clear (queue) + "Remove all elements from QUEUE." + (setf (queue-head queue) nil + (queue-tail queue) nil)) + + +(queue--when-generators + (iter-defun queue-iter (queue) + "Return a queue iterator object. + +Calling `iter-next' on this object will retrieve the next element +from the queue. The queue itself is not modified." + (let ((list (queue-head queue))) + (while list (iter-yield (pop list)))))) + + +(provide 'queue) + + +;;; queue.el ends here diff --git a/.emacs.d/lisp/multiple-cursors/rectangular-region-mode.el b/.emacs.d/lisp/rectangular-region-mode.el similarity index 100% rename from .emacs.d/lisp/multiple-cursors/rectangular-region-mode.el rename to .emacs.d/lisp/rectangular-region-mode.el diff --git a/.emacs.d/lisp/s.el b/.emacs.d/lisp/s.el new file mode 100644 index 0000000..cae199b --- /dev/null +++ b/.emacs.d/lisp/s.el @@ -0,0 +1,792 @@ +;;; s.el --- The long lost Emacs string manipulation library. -*- lexical-binding: t -*- + +;; Copyright (C) 2012-2022 Magnar Sveen + +;; Author: Magnar Sveen +;; Maintainer: Jason Milkins +;; Version: 1.13.1 +;; Keywords: strings + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; The long lost Emacs string manipulation library. +;; +;; See documentation on https://github.com/magnars/s.el#functions + +;;; Code: + +;; Silence byte-compiler +(defvar ucs-normalize-combining-chars) ; Defined in `ucs-normalize' +(autoload 'slot-value "eieio") + +(defun s-trim-left (s) + "Remove whitespace at the beginning of S." + (declare (pure t) (side-effect-free t)) + (save-match-data + (if (string-match "\\`[ \t\n\r]+" s) + (replace-match "" t t s) + s))) + +(defun s-trim-right (s) + "Remove whitespace at the end of S." + (declare (pure t) (side-effect-free t)) + (save-match-data + (if (string-match "[ \t\n\r]+\\'" s) + (replace-match "" t t s) + s))) + +(defun s-trim (s) + "Remove whitespace at the beginning and end of S." + (declare (pure t) (side-effect-free t)) + (s-trim-left (s-trim-right s))) + +(defun s-collapse-whitespace (s) + "Convert all adjacent whitespace characters to a single space." + (declare (pure t) (side-effect-free t)) + (replace-regexp-in-string "[ \t\n\r]+" " " s)) + +(defun s-unindent (s &optional bol) + "Unindent S which has BOL (beginning of line) indicators. +BOL will default to pipe. You can optionally supply your own." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search nil) + (bol (or bol "|"))) + (s-replace-regexp (concat "^[[:space:]]*" (regexp-quote bol)) "" s))) + +(defun s-split (separator s &optional omit-nulls) + "Split S into substrings bounded by matches for regexp SEPARATOR. +If OMIT-NULLS is non-nil, zero-length substrings are omitted. + +This is a simple wrapper around the built-in `split-string'." + (declare (side-effect-free t)) + (save-match-data + (split-string s separator omit-nulls))) + +(defun s-split-up-to (separator s n &optional omit-nulls) + "Split S up to N times into substrings bounded by matches for regexp SEPARATOR. + +If OMIT-NULLS is non-nil, zero-length substrings are omitted. + +See also `s-split'." + (declare (side-effect-free t)) + (save-match-data + (let ((op 0) + (r nil)) + (with-temp-buffer + (insert s) + (setq op (goto-char (point-min))) + (while (and (re-search-forward separator nil t) + (< 0 n)) + (let ((sub (buffer-substring op (match-beginning 0)))) + (unless (and omit-nulls + (equal sub "")) + (push sub r))) + (setq op (goto-char (match-end 0))) + (setq n (1- n))) + (let ((sub (buffer-substring op (point-max)))) + (unless (and omit-nulls + (equal sub "")) + (push sub r)))) + (nreverse r)))) + +(defun s-lines (s) + "Splits S into a list of strings on newline characters." + (declare (pure t) (side-effect-free t)) + (s-split "\\(\r\n\\|[\n\r]\\)" s)) + +(defun s-join (separator strings) + "Join all the strings in STRINGS with SEPARATOR in between." + (declare (pure t) (side-effect-free t)) + (mapconcat 'identity strings separator)) + +(defun s-concat (&rest strings) + "Join all the string arguments into one string." + (declare (pure t) (side-effect-free t)) + (apply 'concat strings)) + +(defun s-prepend (prefix s) + "Concatenate PREFIX and S." + (declare (pure t) (side-effect-free t)) + (concat prefix s)) + +(defun s-append (suffix s) + "Concatenate S and SUFFIX." + (declare (pure t) (side-effect-free t)) + (concat s suffix)) + +(defun s-splice (needle n s) + "Splice NEEDLE into S at position N. +0 is the beginning of the string, -1 is the end." + (if (< n 0) + (let ((left (substring s 0 (+ 1 n (length s)))) + (right (s-right (- -1 n) s))) + (concat left needle right)) + (let ((left (s-left n s)) + (right (substring s n (length s)))) + (concat left needle right)))) + + +(defun s-repeat (num s) + "Make a string of S repeated NUM times." + (declare (pure t) (side-effect-free t)) + (let (ss) + (while (> num 0) + (setq ss (cons s ss)) + (setq num (1- num))) + (apply 'concat ss))) + +(defun s-chop-suffix (suffix s) + "Remove SUFFIX if it is at end of S." + (declare (pure t) (side-effect-free t)) + (let ((pos (- (length suffix)))) + (if (and (>= (length s) (length suffix)) + (string= suffix (substring s pos))) + (substring s 0 pos) + s))) + +(defun s-chop-suffixes (suffixes s) + "Remove SUFFIXES one by one in order, if they are at the end of S." + (declare (pure t) (side-effect-free t)) + (while suffixes + (setq s (s-chop-suffix (car suffixes) s)) + (setq suffixes (cdr suffixes))) + s) + +(defun s-chop-prefix (prefix s) + "Remove PREFIX if it is at the start of S." + (declare (pure t) (side-effect-free t)) + (let ((pos (length prefix))) + (if (and (>= (length s) (length prefix)) + (string= prefix (substring s 0 pos))) + (substring s pos) + s))) + +(defun s-chop-prefixes (prefixes s) + "Remove PREFIXES one by one in order, if they are at the start of S." + (declare (pure t) (side-effect-free t)) + (while prefixes + (setq s (s-chop-prefix (car prefixes) s)) + (setq prefixes (cdr prefixes))) + s) + +(defun s-shared-start (s1 s2) + "Returns the longest prefix S1 and S2 have in common." + (declare (pure t) (side-effect-free t)) + (let ((cmp (compare-strings s1 0 (length s1) s2 0 (length s2)))) + (if (eq cmp t) s1 (substring s1 0 (1- (abs cmp)))))) + +(defun s-shared-end (s1 s2) + "Returns the longest suffix S1 and S2 have in common." + (declare (pure t) (side-effect-free t)) + (let* ((l1 (length s1)) + (l2 (length s2)) + (search-length (min l1 l2)) + (i 0)) + (while (and (< i search-length) + (= (aref s1 (- l1 i 1)) (aref s2 (- l2 i 1)))) + (setq i (1+ i))) + ;; If I is 0, then it means that there's no common suffix between + ;; S1 and S2. + ;; + ;; However, since (substring s (- 0)) will return the whole + ;; string, `s-shared-end' should simply return the empty string + ;; when I is 0. + (if (zerop i) + "" + (substring s1 (- i))))) + +(defun s-chomp (s) + "Remove one trailing `\\n`, `\\r` or `\\r\\n` from S." + (declare (pure t) (side-effect-free t)) + (s-chop-suffixes '("\n" "\r") s)) + +(defun s-truncate (len s &optional ellipsis) + "If S is longer than LEN, cut it down and add ELLIPSIS to the end. + +The resulting string, including ellipsis, will be LEN characters +long. + +When not specified, ELLIPSIS defaults to ‘...’." + (declare (pure t) (side-effect-free t)) + (unless ellipsis + (setq ellipsis "...")) + (if (> (length s) len) + (format "%s%s" (substring s 0 (- len (length ellipsis))) ellipsis) + s)) + +(defun s-word-wrap (len s) + "If S is longer than LEN, wrap the words with newlines." + (declare (side-effect-free t)) + (save-match-data + (with-temp-buffer + (insert s) + (let ((fill-column len)) + (fill-region (point-min) (point-max))) + (buffer-substring (point-min) (point-max))))) + +(defun s-center (len s) + "If S is shorter than LEN, pad it with spaces so it is centered." + (declare (pure t) (side-effect-free t)) + (let ((extra (max 0 (- len (length s))))) + (concat + (make-string (ceiling extra 2) ?\s) + s + (make-string (floor extra 2) ?\s)))) + +(defun s-pad-left (len padding s) + "If S is shorter than LEN, pad it with PADDING on the left." + (declare (pure t) (side-effect-free t)) + (let ((extra (max 0 (- len (length s))))) + (concat (make-string extra (string-to-char padding)) + s))) + +(defun s-pad-right (len padding s) + "If S is shorter than LEN, pad it with PADDING on the right." + (declare (pure t) (side-effect-free t)) + (let ((extra (max 0 (- len (length s))))) + (concat s + (make-string extra (string-to-char padding))))) + +(defun s-left (len s) + "Returns up to the LEN first chars of S." + (declare (pure t) (side-effect-free t)) + (if (> (length s) len) + (substring s 0 len) + s)) + +(defun s-right (len s) + "Returns up to the LEN last chars of S." + (declare (pure t) (side-effect-free t)) + (let ((l (length s))) + (if (> l len) + (substring s (- l len) l) + s))) + +(defun s-chop-left (len s) + "Remove the first LEN chars from S." + (let ((l (length s))) + (if (> l len) + (substring s len l) + ""))) + +(defun s-chop-right (len s) + "Remove the last LEN chars from S." + (let ((l (length s))) + (if (> l len) + (substring s 0 (- l len)) + ""))) + +(defun s-ends-with? (suffix s &optional ignore-case) + "Does S end with SUFFIX? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences. + +Alias: `s-suffix?'" + (declare (pure t) (side-effect-free t)) + (let ((start-pos (- (length s) (length suffix)))) + (and (>= start-pos 0) + (eq t (compare-strings suffix nil nil + s start-pos nil ignore-case))))) + +(defun s-starts-with? (prefix s &optional ignore-case) + "Does S start with PREFIX? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences. + +Alias: `s-prefix?'. This is a simple wrapper around the built-in +`string-prefix-p'." + (declare (pure t) (side-effect-free t)) + (string-prefix-p prefix s ignore-case)) + +(defun s--truthy? (val) + (declare (pure t) (side-effect-free t)) + (not (null val))) + +(defun s-contains? (needle s &optional ignore-case) + "Does S contain NEEDLE? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search ignore-case)) + (s--truthy? (string-match-p (regexp-quote needle) s)))) + +(defun s-equals? (s1 s2) + "Is S1 equal to S2? + +This is a simple wrapper around the built-in `string-equal'." + (declare (pure t) (side-effect-free t)) + (string-equal s1 s2)) + +(defun s-less? (s1 s2) + "Is S1 less than S2? + +This is a simple wrapper around the built-in `string-lessp'." + (declare (pure t) (side-effect-free t)) + (string-lessp s1 s2)) + +(defun s-matches? (regexp s &optional start) + "Does REGEXP match S? +If START is non-nil the search starts at that index. + +This is a simple wrapper around the built-in `string-match-p'." + (declare (side-effect-free t)) + (s--truthy? (string-match-p regexp s start))) + +(defun s-blank? (s) + "Is S nil or the empty string?" + (declare (pure t) (side-effect-free t)) + (or (null s) (string= "" s))) + +(defun s-blank-str? (s) + "Is S nil or the empty string or string only contains whitespace?" + (declare (pure t) (side-effect-free t)) + (or (s-blank? s) (s-blank? (s-trim s)))) + +(defun s-present? (s) + "Is S anything but nil or the empty string?" + (declare (pure t) (side-effect-free t)) + (not (s-blank? s))) + +(defun s-presence (s) + "Return S if it's `s-present?', otherwise return nil." + (declare (pure t) (side-effect-free t)) + (and (s-present? s) s)) + +(defun s-lowercase? (s) + "Are all the letters in S in lower case?" + (declare (side-effect-free t)) + (let ((case-fold-search nil)) + (not (string-match-p "[[:upper:]]" s)))) + +(defun s-uppercase? (s) + "Are all the letters in S in upper case?" + (declare (side-effect-free t)) + (let ((case-fold-search nil)) + (not (string-match-p "[[:lower:]]" s)))) + +(defun s-mixedcase? (s) + "Are there both lower case and upper case letters in S?" + (let ((case-fold-search nil)) + (s--truthy? + (and (string-match-p "[[:lower:]]" s) + (string-match-p "[[:upper:]]" s))))) + +(defun s-capitalized? (s) + "In S, is the first letter upper case, and all other letters lower case?" + (declare (side-effect-free t)) + (let ((case-fold-search nil)) + (s--truthy? + (string-match-p "^[[:upper:]][^[:upper:]]*$" s)))) + +(defun s-numeric? (s) + "Is S a number?" + (declare (pure t) (side-effect-free t)) + (s--truthy? + (string-match-p "^[0-9]+$" s))) + +(defun s-replace (old new s) + "Replaces OLD with NEW in S." + (declare (pure t) (side-effect-free t)) + (replace-regexp-in-string (regexp-quote old) new s t t)) + +(defalias 's-replace-regexp 'replace-regexp-in-string) + +(defun s--aget (alist key) + "Get the value of KEY in ALIST." + (declare (pure t) (side-effect-free t)) + (cdr (assoc-string key alist))) + +(defun s-replace-all (replacements s) + "REPLACEMENTS is a list of cons-cells. Each `car` is replaced with `cdr` in S." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search nil)) + (replace-regexp-in-string (regexp-opt (mapcar 'car replacements)) + (lambda (it) (s--aget replacements it)) + s t t))) + +(defun s-downcase (s) + "Convert S to lower case. + +This is a simple wrapper around the built-in `downcase'." + (declare (side-effect-free t)) + (downcase s)) + +(defun s-upcase (s) + "Convert S to upper case. + +This is a simple wrapper around the built-in `upcase'." + (declare (side-effect-free t)) + (upcase s)) + +(defun s-capitalize (s) + "Convert S first word's first character to upper and the rest to lower case." + (declare (side-effect-free t)) + (concat (upcase (substring s 0 1)) (downcase (substring s 1)))) + +(defun s-titleize (s) + "Convert in S each word's first character to upper and the rest to lower case. + +This is a simple wrapper around the built-in `capitalize'." + (declare (side-effect-free t)) + (capitalize s)) + +(defmacro s-with (s form &rest more) + "Threads S through the forms. Inserts S as the last item +in the first form, making a list of it if it is not a list +already. If there are more forms, inserts the first form as the +last item in second form, etc." + (declare (debug (form &rest [&or (function &rest form) fboundp]))) + (if (null more) + (if (listp form) + `(,(car form) ,@(cdr form) ,s) + (list form s)) + `(s-with (s-with ,s ,form) ,@more))) + +(put 's-with 'lisp-indent-function 1) + +(defun s-index-of (needle s &optional ignore-case) + "Returns first index of NEEDLE in S, or nil. + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search ignore-case)) + (string-match-p (regexp-quote needle) s))) + +(defun s-reverse (s) + "Return the reverse of S." + (declare (pure t) (side-effect-free t)) + (save-match-data + (if (multibyte-string-p s) + (let ((input (string-to-list s)) + output) + (require 'ucs-normalize) + (while input + ;; Handle entire grapheme cluster as a single unit + (let ((grapheme (list (pop input)))) + (while (memql (car input) ucs-normalize-combining-chars) + (push (pop input) grapheme)) + (setq output (nconc (nreverse grapheme) output)))) + (concat output)) + (concat (nreverse (string-to-list s)))))) + +(defun s-match-strings-all (regex string) + "Return a list of matches for REGEX in STRING. + +Each element itself is a list of matches, as per +`match-string'. Multiple matches at the same position will be +ignored after the first." + (declare (side-effect-free t)) + (save-match-data + (let ((all-strings ()) + (i 0)) + (while (and (< i (length string)) + (string-match regex string i)) + (setq i (1+ (match-beginning 0))) + (let (strings + (num-matches (/ (length (match-data)) 2)) + (match 0)) + (while (/= match num-matches) + (push (match-string match string) strings) + (setq match (1+ match))) + (push (nreverse strings) all-strings))) + (nreverse all-strings)))) + +(defun s-matched-positions-all (regexp string &optional subexp-depth) + "Return a list of matched positions for REGEXP in STRING. +SUBEXP-DEPTH is 0 by default." + (declare (side-effect-free t)) + (if (null subexp-depth) + (setq subexp-depth 0)) + (save-match-data + (let ((pos 0) result) + (while (and (string-match regexp string pos) + (< pos (length string))) + (push (cons (match-beginning subexp-depth) (match-end subexp-depth)) result) + (setq pos (match-end 0))) + (nreverse result)))) + +(defun s-match (regexp s &optional start) + "When the given expression matches the string, this function returns a list +of the whole matching string and a string for each matched subexpressions. +Subexpressions that didn't match are represented by nil elements +in the list, except that non-matching subexpressions at the end +of REGEXP might not appear at all in the list. That is, the +returned list can be shorter than the number of subexpressions in +REGEXP plus one. If REGEXP did not match the returned value is +an empty list (nil). + +When START is non-nil the search will start at that index." + (declare (side-effect-free t)) + (save-match-data + (if (string-match regexp s start) + (let ((match-data-list (match-data)) + result) + (while match-data-list + (let* ((beg (car match-data-list)) + (end (cadr match-data-list)) + (subs (if (and beg end) (substring s beg end) nil))) + (setq result (cons subs result)) + (setq match-data-list + (cddr match-data-list)))) + (nreverse result))))) + +(defun s-slice-at (regexp s) + "Slices S up at every index matching REGEXP." + (declare (side-effect-free t)) + (if (s-blank? s) + (list s) + (let (ss) + (while (not (s-blank? s)) + (save-match-data + (let ((i (string-match regexp s 1))) + (if i + (setq ss (cons (substring s 0 i) ss) + s (substring s i)) + (setq ss (cons s ss) + s ""))))) + (nreverse ss)))) + +(defun s-split-words (s) + "Split S into list of words." + (declare (side-effect-free t)) + (s-split + "[^[:word:]0-9]+" + (let ((case-fold-search nil)) + (replace-regexp-in-string + "\\([[:lower:]]\\)\\([[:upper:]]\\)" "\\1 \\2" + (replace-regexp-in-string "\\([[:upper:]]\\)\\([[:upper:]][0-9[:lower:]]\\)" "\\1 \\2" s))) + t)) + +(defun s--mapcar-head (fn-head fn-rest list) + "Like MAPCAR, but applies a different function to the first element." + (if list + (cons (funcall fn-head (car list)) (mapcar fn-rest (cdr list))))) + +(defun s-lower-camel-case (s) + "Convert S to lowerCamelCase." + (declare (side-effect-free t)) + (s-join "" (s--mapcar-head 'downcase 'capitalize (s-split-words s)))) + +(defun s-upper-camel-case (s) + "Convert S to UpperCamelCase." + (declare (side-effect-free t)) + (s-join "" (mapcar 'capitalize (s-split-words s)))) + +(defun s-snake-case (s) + "Convert S to snake_case." + (declare (side-effect-free t)) + (s-join "_" (mapcar 'downcase (s-split-words s)))) + +(defun s-dashed-words (s) + "Convert S to dashed-words." + (declare (side-effect-free t)) + (s-join "-" (mapcar 'downcase (s-split-words s)))) + +(defun s-spaced-words (s) + "Convert S to spaced words." + (declare (side-effect-free t)) + (s-join " " (s-split-words s))) + +(defun s-capitalized-words (s) + "Convert S to Capitalized words." + (declare (side-effect-free t)) + (let ((words (s-split-words s))) + (s-join " " (cons (capitalize (car words)) (mapcar 'downcase (cdr words)))))) + +(defun s-titleized-words (s) + "Convert S to Titleized Words." + (declare (side-effect-free t)) + (s-join " " (mapcar 's-titleize (s-split-words s)))) + +(defun s-word-initials (s) + "Convert S to its initials." + (declare (side-effect-free t)) + (s-join "" (mapcar (lambda (ss) (substring ss 0 1)) + (s-split-words s)))) + +;; Errors for s-format +(progn + (put 's-format-resolve + 'error-conditions + '(error s-format s-format-resolve)) + (put 's-format-resolve + 'error-message + "Cannot resolve a template to values")) + +(defun s-format (template replacer &optional extra) + "Format TEMPLATE with the function REPLACER. + +REPLACER takes an argument of the format variable and optionally +an extra argument which is the EXTRA value from the call to +`s-format'. + +Several standard `s-format' helper functions are recognized and +adapted for this: + + (s-format \"${name}\" \\='gethash hash-table) + (s-format \"${name}\" \\='aget alist) + (s-format \"$0\" \\='elt sequence) + +The REPLACER function may be used to do any other kind of +transformation." + (let ((saved-match-data (match-data))) + (unwind-protect + (replace-regexp-in-string + "\\$\\({\\([^}]+\\)}\\|[0-9]+\\)" + (lambda (md) + (let ((var + (let ((m (match-string 2 md))) + (if m m + (string-to-number (match-string 1 md))))) + (replacer-match-data (match-data))) + (unwind-protect + (let ((v + (cond + ((eq replacer 'gethash) + (funcall replacer var extra)) + ((eq replacer 'aget) + (funcall 's--aget extra var)) + ((eq replacer 'elt) + (funcall replacer extra var)) + ((eq replacer 'oref) + (funcall #'slot-value extra (intern var))) + (t + (set-match-data saved-match-data) + (if extra + (funcall replacer var extra) + (funcall replacer var)))))) + (if v (format "%s" v) (signal 's-format-resolve md))) + (set-match-data replacer-match-data)))) + template + ;; Need literal to make sure it works + t t) + (set-match-data saved-match-data)))) + +(defvar s-lex-value-as-lisp nil + "If `t' interpolate lisp values as lisp. + +`s-lex-format' inserts values with (format \"%S\").") + +(defun s-lex-fmt|expand (fmt) + "Expand FMT into lisp." + (declare (side-effect-free t)) + (list 's-format fmt (quote 'aget) + (append '(list) + (mapcar + (lambda (matches) + (list + 'cons + (cadr matches) + `(format + (if s-lex-value-as-lisp "%S" "%s") + ,(intern (cadr matches))))) + (s-match-strings-all "${\\([^}]+\\)}" fmt))))) + +(defmacro s-lex-format (format-str) + "`s-format` with the current environment. + +FORMAT-STR may use the `s-format' variable reference to refer to +any variable: + + (let ((x 1)) + (s-lex-format \"x is: ${x}\")) + +The values of the variables are interpolated with \"%s\" unless +the variable `s-lex-value-as-lisp' is `t' and then they are +interpolated with \"%S\"." + (declare (debug (form))) + (s-lex-fmt|expand format-str)) + +(defun s-count-matches (regexp s &optional start end) + "Count occurrences of `regexp' in `s'. + +`start', inclusive, and `end', exclusive, delimit the part of `s' to +match. `start' and `end' are both indexed starting at 1; the initial +character in `s' is index 1. + +This function starts looking for the next match from the end of the +previous match. Hence, it ignores matches that overlap a previously +found match. To count overlapping matches, use +`s-count-matches-all'." + (declare (side-effect-free t)) + (save-match-data + (with-temp-buffer + (insert s) + (goto-char (point-min)) + (count-matches regexp (or start 1) (or end (point-max)))))) + +(defun s-count-matches-all (regexp s &optional start end) + "Count occurrences of `regexp' in `s'. + +`start', inclusive, and `end', exclusive, delimit the part of `s' to +match. `start' and `end' are both indexed starting at 1; the initial +character in `s' is index 1. + +This function starts looking for the next match from the second +character of the previous match. Hence, it counts matches that +overlap a previously found match. To ignore matches that overlap a +previously found match, use `s-count-matches'." + (declare (side-effect-free t)) + (let* ((anchored-regexp (format "^%s" regexp)) + (match-count 0) + (i 0) + (narrowed-s (substring s (if start (1- start) 0) + (when end (1- end))))) + (save-match-data + (while (< i (length narrowed-s)) + (when (s-matches? anchored-regexp (substring narrowed-s i)) + (setq match-count (1+ match-count))) + (setq i (1+ i)))) + match-count)) + +(defun s-wrap (s prefix &optional suffix) + "Wrap string S with PREFIX and optionally SUFFIX. + +Return string S with PREFIX prepended. If SUFFIX is present, it +is appended, otherwise PREFIX is used as both prefix and +suffix." + (declare (pure t) (side-effect-free t)) + (concat prefix s (or suffix prefix))) + + +;;; Aliases + +(defalias 's-blank-p 's-blank?) +(defalias 's-blank-str-p 's-blank-str?) +(defalias 's-capitalized-p 's-capitalized?) +(defalias 's-contains-p 's-contains?) +(defalias 's-ends-with-p 's-ends-with?) +(defalias 's-equals-p 's-equals?) +(defalias 's-less-p 's-less?) +(defalias 's-lowercase-p 's-lowercase?) +(defalias 's-matches-p 's-matches?) +(defalias 's-mixedcase-p 's-mixedcase?) +(defalias 's-numeric-p 's-numeric?) +(defalias 's-prefix-p 's-starts-with?) +(defalias 's-prefix? 's-starts-with?) +(defalias 's-present-p 's-present?) +(defalias 's-starts-with-p 's-starts-with?) +(defalias 's-suffix-p 's-ends-with?) +(defalias 's-suffix? 's-ends-with?) +(defalias 's-uppercase-p 's-uppercase?) + + +(provide 's) +;;; s.el ends here diff --git a/.emacs.d/lisp/swiper.el b/.emacs.d/lisp/swiper.el new file mode 100644 index 0000000..c35180e --- /dev/null +++ b/.emacs.d/lisp/swiper.el @@ -0,0 +1,1818 @@ +;;; swiper.el --- Isearch with an overview. Oh, man! -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2025 Free Software Foundation, Inc. + +;; Author: Oleh Krehel +;; Maintainer: Basil L. Contovounesios +;; URL: https://github.com/abo-abo/swiper +;; Version: 0.15.1 +;; Package-Requires: ((emacs "24.5") (ivy "0.15.1")) +;; Keywords: matching + +;; This file is part of GNU Emacs. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; For a full copy of the GNU General Public License +;; see . + +;;; Commentary: + +;; This package gives an overview of the current regex search +;; candidates. The search regex can be split into groups with a +;; space. Each group is highlighted with a different face. +;; +;; It can double as a quick `regex-builder', although only single +;; lines will be matched. + +;;; Code: + +(require 'cl-lib) +(require 'ivy) + +(eval-when-compile + (unless (fboundp 'static-if) + (defmacro static-if (condition then-form &rest else-forms) + "Expand to THEN-FORM or ELSE-FORMS based on compile-time CONDITION. +Polyfill for Emacs 30 `static-if'." + (declare (debug (sexp sexp &rest sexp)) (indent 2)) + (if (eval condition lexical-binding) + then-form + (macroexp-progn else-forms))))) + +(defgroup swiper nil + "`isearch' with an overview." + :group 'matching + :prefix "swiper-") + +(defface swiper-match-face-1 + '((t :inherit lazy-highlight)) + "The background face for `swiper' matches." + :group 'ivy-faces) + +(defface swiper-match-face-2 + '((t :inherit isearch)) + "Face for `swiper' matches modulo 1." + :group 'ivy-faces) + +(defface swiper-match-face-3 + '((t :inherit match)) + "Face for `swiper' matches modulo 2." + :group 'ivy-faces) + +(defface swiper-match-face-4 + '((t :inherit isearch-fail)) + "Face for `swiper' matches modulo 3." + :group 'ivy-faces) + +(defface swiper-background-match-face-1 + '((t :inherit swiper-match-face-1)) + "The background face for non-current `swiper' matches." + :group 'ivy-faces) + +(defface swiper-background-match-face-2 + '((t :inherit swiper-match-face-2)) + "Face for non-current `swiper' matches modulo 1." + :group 'ivy-faces) + +(defface swiper-background-match-face-3 + '((t :inherit swiper-match-face-3)) + "Face for non-current `swiper' matches modulo 2." + :group 'ivy-faces) + +(defface swiper-background-match-face-4 + '((t :inherit swiper-match-face-4)) + "Face for non-current `swiper' matches modulo 3." + :group 'ivy-faces) + +(defface swiper-line-face + '((t :inherit highlight)) + "Face for current `swiper' line." + :group 'ivy-faces) + +(defcustom swiper-faces '(swiper-match-face-1 + swiper-match-face-2 + swiper-match-face-3 + swiper-match-face-4) + "List of `swiper' faces for group matches." + :group 'ivy-faces + :type '(repeat face)) + +(defvar swiper-background-faces + '(swiper-background-match-face-1 + swiper-background-match-face-2 + swiper-background-match-face-3 + swiper-background-match-face-4) + "Like `swiper-faces', but used for all matches except the current one.") + +(defun swiper--recompute-background-faces () + (let ((faces '(swiper-background-match-face-1 + swiper-background-match-face-2 + swiper-background-match-face-3 + swiper-background-match-face-4)) + (colir-compose-method #'colir-compose-soft-light)) + (cl-mapc (lambda (f1 f2) + (let* ((bg (face-background f1)) + ;; FIXME: (colir-color-parse "color-22") is nil. + (bg (and bg (colir-color-parse bg)))) + (when bg + (setq bg (colir-blend bg (colir-color-parse "#ffffff"))) + (set-face-background f2 bg)))) + swiper-faces + faces))) +(swiper--recompute-background-faces) + +(defcustom swiper-min-highlight 2 + "Only highlight matches for regexps at least this long." + :type 'integer) + +(defcustom swiper-include-line-number-in-search nil + "Include line number in text of search candidates." + :type 'boolean + :group 'swiper) + +(defcustom swiper-goto-start-of-match nil + "When non-nil, go to the start of the match, not its end. +Treated as non-nil when searching backwards." + :type 'boolean + :group 'swiper) + +(defun swiper-C-s (&optional arg) + "Move cursor vertically down ARG candidates. +If the input is empty, select the previous history element instead." + (interactive "p") + (if (string= ivy-text "") + (ivy-previous-history-element 1) + (ivy-next-line arg))) + +(defvar swiper-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-s") #'swiper-C-s) + (define-key map (kbd "M-q") #'swiper-query-replace) + (define-key map (kbd "C-l") #'swiper-recenter-top-bottom) + (define-key map (kbd "C-'") #'swiper-avy) + (define-key map (kbd "C-7") #'swiper-mc) + (define-key map (kbd "C-c C-f") #'swiper-toggle-face-matching) + map) + "Keymap for swiper.") + +(defvar swiper--query-replace-overlays nil) + +(defun swiper--query-replace-updatefn () + (let ((lisp (ignore-errors (nth 2 (query-replace-compile-replacement ivy-text t))))) + (dolist (ov swiper--query-replace-overlays) + (overlay-put + ov 'after-string + (propertize + (condition-case nil + (with-current-buffer (overlay-buffer ov) + (set-match-data (overlay-get ov 'md)) + (if (consp lisp) + (eval lisp) + (match-substitute-replacement ivy-text))) + (error ivy-text)) + 'face 'error))))) + +(defun swiper--query-replace-cleanup () + (while swiper--query-replace-overlays + (delete-overlay (pop swiper--query-replace-overlays)))) + +(defun swiper--query-replace-setup () + (with-ivy-window + (let ((end (window-end (selected-window) t)) + (re (ivy-re-to-str ivy-regex))) + (save-excursion + (beginning-of-line) + (while (re-search-forward re end t) + (let ((ov (make-overlay (1- (match-end 0)) (match-end 0))) + (md (match-data t))) + (overlay-put + ov 'matches + (mapcar + (lambda (x) + (list `(match-string ,x) (match-string x))) + (number-sequence 0 (1- (/ (length md) 2))))) + (overlay-put ov 'md md) + (push ov swiper--query-replace-overlays)) + (unless (> (match-end 0) (match-beginning 0)) + (forward-char))))))) + +(defun swiper-query-replace () + "Start `query-replace' with string to replace from last search string." + (interactive) + (cond ((null (window-minibuffer-p)) + (user-error "Should only be called in the minibuffer through `swiper-map'")) + ((string= "" ivy-text) + (user-error "Empty input")) + (t + (swiper--query-replace-setup) + (unwind-protect + (let* ((enable-recursive-minibuffers t) + (from (ivy-re-to-str ivy-regex)) + (groups (number-sequence 1 ivy--subexps)) + (default + (list + (mapconcat (lambda (i) (format "\\%d" i)) groups " ") + (format "\\,(concat %s)" + (if (<= ivy--subexps 1) + "\\&" + (mapconcat + (lambda (i) (format "\\%d" i)) + groups + " \" \" "))))) + (to + (query-replace-compile-replacement + (ivy-read + (format "Query replace %s with: " from) nil + :def default + :caller 'swiper-query-replace) + t))) + (swiper--cleanup) + (ivy-exit-with-action + (lambda (_) + (with-ivy-window + (move-beginning-of-line 1) + (let ((inhibit-read-only t)) + (perform-replace from to + t t nil)))))) + (swiper--query-replace-cleanup))))) + +(ivy-configure 'swiper-query-replace + :update-fn #'swiper--query-replace-updatefn) +(function-put #'swiper-query-replace 'no-counsel-M-x t) + +(defvar inhibit-message) + +(defun swiper-all-query-replace () + "Start `query-replace' with string to replace from last search string." + (interactive) + (if (null (window-minibuffer-p)) + (user-error + "Should only be called in the minibuffer through `swiper-all-map'") + (let* ((enable-recursive-minibuffers t) + (from (ivy--regex ivy-text)) + (to (query-replace-read-to from "Query replace" t))) + (swiper--cleanup) + (ivy-exit-with-action + (lambda (_) + (let ((wnd-conf (current-window-configuration)) + (inhibit-message t)) + (unwind-protect + (dolist (cand ivy--old-cands) + (let ((buffer (get-text-property 0 'buffer cand))) + (switch-to-buffer buffer) + (goto-char (point-min)) + (perform-replace from to t t nil))) + (set-window-configuration wnd-conf)))))))) +(function-put #'swiper-all-query-replace 'no-counsel-M-x t) + +(defvar avy-all-windows) +(defvar avy-style) +(defvar avy-keys) +(declare-function avy--overlay-post "ext:avy") +(declare-function avy-action-goto "ext:avy") +(declare-function avy-candidate-beg "ext:avy") +(declare-function avy--done "ext:avy") +(declare-function avy--make-backgrounds "ext:avy") +(declare-function avy-window-list "ext:avy") +(declare-function avy-read "ext:avy") +(declare-function avy-read-de-bruijn "ext:avy") +(declare-function avy-tree "ext:avy") +(declare-function avy-push-mark "ext:avy") +(declare-function avy--remove-leading-chars "ext:avy") + +(defun swiper--avy-candidates () + (let* ((visible-overlays + (with-ivy-window (overlays-in (window-start) (window-end)))) + ;; We'll have overlapping overlays, so we sort all the + ;; overlays in the visible region by their start, and then + ;; throw out non-Swiper overlays or overlapping Swiper + ;; overlays. + (visible-overlays + (static-if (bound-and-true-p ivy--new-sort-p) + (sort visible-overlays :key #'overlay-start :in-place t) + (cl-sort visible-overlays #'< :key #'overlay-start))) + (min-overlay-start 0) + (overlays-for-avy + (cl-delete-if-not + (lambda (ov) + (when (and (>= (overlay-start ov) + min-overlay-start) + (memq (overlay-get ov 'face) + (append swiper-faces swiper-background-faces))) + (setq min-overlay-start (overlay-start ov)))) + visible-overlays)) + (offset (if (eq (ivy-state-caller ivy-last) 'swiper) 1 0))) + (nconc + (mapcar (lambda (ov) + (cons (overlay-start ov) + (overlay-get ov 'window))) + overlays-for-avy) + (save-excursion + (save-restriction + (narrow-to-region (window-start) (window-end)) + (goto-char (point-min)) + (forward-line) + (let ((win (selected-window)) + cands) + (while (not (eobp)) + (push (cons (+ (point) offset) win) + cands) + (forward-line)) + cands)))))) + +(defun swiper--avy-candidate () + (let ((candidates (swiper--avy-candidates)) + (avy-all-windows nil)) + (unwind-protect + (prog2 + (avy--make-backgrounds + (append (avy-window-list) + (list (ivy-state-window ivy-last)))) + (if (eq avy-style 'de-bruijn) + (avy-read-de-bruijn candidates avy-keys) + (avy-read (avy-tree candidates avy-keys) + #'avy--overlay-post + #'avy--remove-leading-chars)) + (avy-push-mark)) + (avy--done)))) + +(defun swiper--avy-index (pos) + "Return `ivy--index' for `avy' candidate at minibuffer POS." + ;; Position in original buffer. + (let ((opos (get-text-property pos 'point))) + (or + ;; Find `swiper-isearch' index based on buffer position. + (and opos (cl-position opos ivy--all-candidates)) + ;; Find `swiper' index based on line number. + (let ((nlines (count-lines (point-min) (point-max)))) + (+ (car (ivy--minibuffer-index-bounds + ivy--index ivy--length ivy-height)) + (line-number-at-pos pos) + (if (or (= nlines (1+ ivy-height)) + (< ivy--length ivy-height)) + 0 + (- ivy-height nlines)) + -2))))) + +(defun swiper--avy-goto (candidate) + (cond ((let ((win (cdr-safe candidate))) + (and win (window-minibuffer-p win))) + (setq ivy--index (swiper--avy-index (car candidate))) + (ivy--exhibit) + (ivy-done) + (ivy-call)) + ((or (consp candidate) + (number-or-marker-p candidate)) + (ivy-quit-and-run + (avy-action-goto (avy-candidate-beg candidate)))))) + +;;;###autoload +(defun swiper-avy () + "Jump to one of the current swiper candidates with `avy'." + (interactive) + (unless (require 'avy nil 'noerror) + (user-error "Package avy isn't installed")) + (cl-case (length ivy-text) + (0 + (user-error "Need at least one char of input")) + (1 + ;; FIXME: `swiper--update-input-ivy' expects string candidates, + ;; but `swiper-isearch' now uses buffer positions. + (when (stringp (ivy-state-current ivy-last)) + (let ((swiper-min-highlight 1)) + (swiper--update-input-ivy))))) + (swiper--avy-goto (swiper--avy-candidate))) + +(declare-function mc/create-fake-cursor-at-point "ext:multiple-cursors-core") +(declare-function multiple-cursors-mode "ext:multiple-cursors-core") + +(defun swiper-mc () + "Create a fake cursor for each `swiper' candidate. +Make sure `swiper-mc' is on `mc/cmds-to-run-once' list." + (interactive) + (unless (require 'multiple-cursors nil t) + (error "Multiple-cursors isn't installed")) + (unless (window-minibuffer-p) + (error "Call me only from `swiper'")) + (let ((cands (nreverse ivy--old-cands)) + (action (ivy--get-action ivy-last))) + (unless (string= ivy-text "") + (ivy-exit-with-action + (lambda (_) + (let (cand) + (while (setq cand (pop cands)) + (funcall action cand) + (when cands + (mc/create-fake-cursor-at-point)))) + (multiple-cursors-mode 1)))))) + +(defvar swiper--current-window-start nil + "Store `window-start' to restore it later. +This prevents a \"jumping\" behavior which occurs when variables +such as `scroll-conservatively' are set to a high value.") + +(defun swiper-recenter-top-bottom (&optional arg) + "Call (`recenter-top-bottom' ARG)." + (interactive "P") + (with-ivy-window + (recenter-top-bottom arg) + (setq swiper--current-window-start (window-start)))) + +(defvar swiper-font-lock-exclude + '(Man-mode + adoc-mode + bbdb-mode + bongo-library-mode + bongo-mode + bongo-playlist-mode + bookmark-bmenu-mode + circe-channel-mode + circe-query-mode + circe-server-mode + deadgrep-mode + debbugs-gnu-mode + dired-mode + elfeed-search-mode + elfeed-show-mode + emms-playlist-mode + emms-stream-mode + erc-mode + eshell-mode + eww-mode + forth-block-mode + forth-mode + fundamental-mode + gnus-article-mode + gnus-group-mode + gnus-summary-mode + help-mode + helpful-mode + jabber-chat-mode + magit-popup-mode + matrix-client-mode + matrix-client-room-list-mode + mu4e-headers-mode + mu4e-view-mode + nix-mode + notmuch-search-mode + notmuch-tree-mode + occur-edit-mode + occur-mode + org-agenda-mode + package-menu-mode + rcirc-mode + sauron-mode + sieve-mode + treemacs-mode + twittering-mode + vc-dir-mode + w3m-mode + woman-mode + xref--xref-buffer-mode) + "List of major-modes that are incompatible with `font-lock-ensure'.") + +(defun swiper-font-lock-ensure-p () + "Return non-nil if we should not `font-lock-ensure'." + (or (derived-mode-p 'magit-mode) + (bound-and-true-p magit-blame-mode) + (memq major-mode swiper-font-lock-exclude) + (not (derived-mode-p 'prog-mode)))) + +(defun swiper-font-lock-ensure () + "Ensure the entire buffer is highlighted." + (unless (or (swiper-font-lock-ensure-p) + (> (buffer-size) 100000) + (not font-lock-mode)) + (static-if (fboundp 'font-lock-ensure) + ;; Added in Emacs 25.1. + (font-lock-ensure) + (font-lock-fontify-buffer)))) + +(defvar swiper--format-spec "" + "Store the current candidates format spec.") + +(defvar swiper--width nil + "Store the number of digits needed for the longest line number.") + +(defvar swiper-use-visual-line nil + "When non-nil, use `line-move' instead of `forward-line'.") + +(defvar dired-isearch-filenames) +(declare-function dired-move-to-filename "dired") + +(defun swiper--line () + (let* ((beg (cond ((and (eq major-mode 'dired-mode) + (bound-and-true-p dired-isearch-filenames)) + (dired-move-to-filename) + (point)) + (swiper-use-visual-line + (save-excursion + (beginning-of-visual-line) + (point))) + (t + (point)))) + (end (if swiper-use-visual-line + (save-excursion + (end-of-visual-line) + (point)) + (line-end-position)))) + + (concat + " " + (buffer-substring beg end)))) + +(defvar swiper-use-visual-line-p + (lambda (n-lines) + (and visual-line-mode + ;; super-slow otherwise + (< (buffer-size) 20000) + (< n-lines 400))) + "A predicate that decides whether `line-move' or `forward-line' is used. +Note that `line-move' can be very slow.") + +(defun swiper--candidates (&optional numbers-width) + "Return a list of this buffer lines. + +NUMBERS-WIDTH, when specified, is used for width spec of line +numbers; replaces calculating the width from buffer line count." + (let* ((inhibit-field-text-motion t) + (n-lines (count-lines (point-min) (point-max)))) + (if (funcall swiper-use-visual-line-p n-lines) + (progn + (when (eq major-mode 'org-mode) + (require 'outline) + (if (fboundp 'outline-show-all) + ;; Added in Emacs 25.1. + (outline-show-all) + (with-no-warnings + (show-all)))) + (setq swiper-use-visual-line t)) + (setq swiper-use-visual-line nil)) + (unless (zerop n-lines) + (setq swiper--width (or numbers-width + (1+ (floor (log n-lines 10))))) + (setq swiper--format-spec + (format "%%-%dd " swiper--width)) + (let ((line-number 1) + (advancer (if swiper-use-visual-line + (lambda (arg) (line-move arg t)) + #'forward-line)) + candidates) + (save-excursion + (goto-char (point-min)) + (swiper-font-lock-ensure) + (while (< (point) (point-max)) + (when (swiper-match-usable-p) + (let ((str (swiper--line))) + (setq str (ivy-cleanup-string str)) + (let ((line-number-str + (format swiper--format-spec line-number))) + (if swiper-include-line-number-in-search + (setq str (concat line-number-str str)) + (put-text-property + 0 1 'display line-number-str str)) + (put-text-property + 0 1 'swiper-line-number line-number str)) + (push str candidates))) + (funcall advancer 1) + (cl-incf line-number)) + (nreverse candidates)))))) + +(defvar swiper--opoint nil + "Value of point when `swiper' or `swiper-isearch' starts.") + +;;;###autoload +(defun swiper-backward (&optional initial-input) + "`isearch-backward' with an overview. +When non-nil, INITIAL-INPUT is the initial search pattern." + (interactive) + (let ((ivy-index-functions-alist + '((swiper . ivy-recompute-index-swiper-backward)))) + (swiper initial-input))) + +;;;###autoload +(defun swiper-thing-at-point () + "`swiper' with `ivy-thing-at-point'." + (interactive) + (let ((thing (ivy-thing-at-point))) + (when (use-region-p) + (deactivate-mark)) + (swiper (regexp-quote thing)))) + +;;;###autoload +(defun swiper-all-thing-at-point () + "`swiper-all' with `ivy-thing-at-point'." + (interactive) + (let ((thing (ivy-thing-at-point))) + (when (use-region-p) + (deactivate-mark)) + (swiper-all (regexp-quote thing)))) + +(defun swiper--extract-matches (regex cands) + "Extract captured REGEX groups from CANDS." + (let (res) + (dolist (cand cands) + (setq cand (substring cand 1)) + (when (string-match regex cand) + (push (mapconcat (lambda (n) (match-string-no-properties n cand)) + (number-sequence + 1 + (/ (- (length (match-data)) 2) 2)) + " ") + res))) + (nreverse res))) + +(defun swiper--occur-cands (fname cands) + (when cands + (with-current-buffer (ivy-state-buffer ivy-last) + (when (eq (ivy-state-caller ivy-last) 'swiper-isearch) + (setq cands (mapcar #'swiper--line-at-point cands))) + (let* ((pt-min (point-min)) + (line-delta + (save-restriction + (widen) + (1- (line-number-at-pos pt-min)))) + (lines + (if (eq (ivy-state-caller ivy-last) 'swiper-isearch) + (swiper--isearch-occur-cands cands) + (mapcar (lambda (s) + (let ((n (swiper--line-number s))) + (setq s (substring s 1)) + (add-text-properties 0 1 (list 'swiper-line-number n) s) + (cons n s))) + cands))) + (offset (+ (length fname) 2))) + (mapcar (lambda (x) + (let ((nn (number-to-string + (+ (car x) line-delta)))) + (remove-text-properties 0 1 '(display) (cdr x)) + (put-text-property 0 (length nn) 'face 'ivy-grep-line-number nn) + (put-text-property 0 1 'offset (+ offset (length nn)) fname) + (format "%s:%s:%s" fname nn (cdr x)))) + lines))))) + +(defun swiper--isearch-occur-cands (cands) + (let* ((last-pt (get-text-property 0 'point (car cands))) + (line (1+ (line-number-at-pos last-pt))) + res pt) + (dolist (cand cands) + (setq pt (get-text-property 0 'point cand)) + (cl-incf line (1- (count-lines last-pt pt))) + (push (cons line cand) res) + (setq last-pt pt)) + (nreverse res))) + +(defun swiper--occur-insert-lines (cands) + (let ((inhibit-read-only t)) + ;; Need precise number of header lines for `wgrep' to work. + (insert (format "-*- mode:grep; default-directory: %S -*-\n\n\n" + default-directory)) + (insert (format "%d candidates:\n" (length cands))) + (ivy--occur-insert-lines cands) + (goto-char (point-min)) + (forward-line 4))) + +(defun swiper--occur-buffer () + (let ((buffer (ivy-state-buffer ivy-last))) + (unless (buffer-live-p buffer) + (setq buffer + (setf (ivy-state-buffer ivy-last) + (find-file-noselect + (plist-get (ivy-state-extra-props ivy-last) :fname)))) + (save-selected-window + (pop-to-buffer buffer)) + (setf (ivy-state-window ivy-last) (selected-window))) + buffer)) + +(defun swiper-occur (&optional cands) + "Generate a custom occur buffer for `swiper'. +When capture groups are present in the input, print them instead of lines." + (setq cands (or ivy-marked-candidates cands)) + (let* ((buffer (swiper--occur-buffer)) + (fname (propertize + (with-ivy-window + (if (buffer-file-name buffer) + (file-name-nondirectory + (buffer-file-name buffer)) + (buffer-name buffer))) + 'face + 'ivy-grep-info)) + (re + (progn + (string-match "\"\\(.*\\)\"" (buffer-name)) + (ivy-set-text (match-string 1 (buffer-name))) + (mapconcat #'identity (ivy--split ivy-text) ".*?"))) + (cands + (swiper--occur-cands + fname + (or cands + (save-window-excursion + (switch-to-buffer buffer) + (if (eq (ivy-state-caller ivy-last) 'swiper) + (let ((ivy--regex-function 'swiper--re-builder)) + (setq ivy--old-re nil) + (ivy--filter re (swiper--candidates))) + (swiper-isearch-function ivy-text))))))) + (if (string-match-p "\\\\(" re) + (insert + (mapconcat #'identity + (swiper--extract-matches + re (with-current-buffer buffer + (swiper--candidates))) + "\n")) + (unless (eq major-mode 'ivy-occur-grep-mode) + (ivy-occur-grep-mode) + (font-lock-mode -1)) + (swiper--occur-insert-lines + (mapcar (lambda (cand) (concat "./" cand)) cands))))) + +(declare-function evil-set-jump "ext:evil-jumps") + +(defvar swiper--current-line nil) +(defvar swiper--current-match-start nil) +(defvar swiper--point-min nil) +(defvar swiper--point-max nil) +(defvar swiper--reveal-mode nil) + +(defun swiper--init () + "Perform initialization common to both completion methods." + (setq swiper--current-line nil) + (setq swiper--current-match-start nil) + (setq swiper--current-window-start nil) + (setq swiper--opoint (point)) + (setq swiper--point-min (point-min)) + (setq swiper--point-max (point-max)) + (when (setq swiper--reveal-mode + (bound-and-true-p reveal-mode)) + (reveal-mode -1)) + (lazy-highlight-cleanup t) + (setq isearch-opened-overlays nil) + (when (bound-and-true-p evil-mode) + (evil-set-jump))) + +(defun swiper--normalize-regex (re) + "Normalize the Swiper regexp RE. +Add a space after a leading `^' for `swiper', and apply +`search-default-mode' if bound in the original buffer." + (replace-regexp-in-string + "^\\(?:\\\\(\\)?\\^" + (concat "\\&" (if (eq 'swiper (ivy-state-caller ivy-last)) " " "")) + (let ((mode (with-ivy-window (bound-and-true-p search-default-mode)))) + (if (functionp mode) + (mapconcat + (lambda (x) + (if (string-match-p "\\`[^$\\^]+\\'" x) + (funcall mode x) + x)) + (split-string re "\\b") "") + re)) + t)) + +(defun swiper--re-builder (str) + "Transform STR into a swiper regex. +This is the regex used in the minibuffer where candidates have +line numbers. For the buffer, use `ivy--regex' instead." + (let* ((re-builder (ivy-alist-setting ivy-re-builders-alist)) + (str (ivy--string-replace "\\n" "\n" str)) + (re (funcall re-builder str))) + (if (consp re) + (mapcar + (lambda (x) + (cons (swiper--normalize-regex (car x)) + (cdr x))) + re) + (swiper--normalize-regex re)))) + +(defvar swiper-history nil + "History for `swiper'.") + +(defvar swiper-invocation-face nil + "The face at the point of invocation of `swiper'.") + +(defcustom swiper-stay-on-quit nil + "When non-nil don't go back to search start on abort." + :type 'boolean) + +;;;###autoload +(defun swiper (&optional initial-input) + "`isearch-forward' with an overview. +When non-nil, INITIAL-INPUT is the initial search pattern." + (interactive) + (let ((candidates (swiper--candidates))) + (swiper--init) + (setq swiper-invocation-face + (plist-get (text-properties-at (point)) 'face)) + (let ((preselect + (if (or swiper-use-visual-line (null search-invisible)) + (count-screen-lines + (point-min) + (save-excursion (beginning-of-visual-line) (point))) + (1- (line-number-at-pos)))) + (minibuffer-allow-text-properties t) + res) + (unwind-protect + (and + (setq res + (ivy-read + "Swiper: " + candidates + :initial-input initial-input + :keymap swiper-map + :preselect + (if initial-input + (cl-position-if + (lambda (x) + (<= (1+ preselect) (swiper--line-number x))) + (progn + (setq ivy--old-re nil) + (ivy--filter initial-input candidates))) + preselect) + :require-match t + :action #'swiper--action + :re-builder #'swiper--re-builder + :history 'swiper-history + :extra-props (list :fname (buffer-file-name)) + :caller 'swiper)) + (point)) + (unless (or res swiper-stay-on-quit) + (goto-char swiper--opoint)) + (isearch-clean-overlays) + (unless (or res (string= ivy-text "")) + (cl-pushnew ivy-text swiper-history)) + (setq swiper--current-window-start nil) + (when swiper--reveal-mode + (reveal-mode 1)))))) + +(ivy-configure 'swiper + :occur #'swiper-occur + :update-fn #'swiper--update-input-ivy + :unwind-fn #'swiper--cleanup + :index-fn #'ivy-recompute-index-swiper) + +(ivy-add-actions 'swiper + `(("w" ,#'swiper-action-copy "copy"))) + +(defun swiper-toggle-face-matching () + "Toggle matching only the candidates with `swiper-invocation-face'." + (interactive) + (setf (ivy-state-matcher ivy-last) + (if (ivy-state-matcher ivy-last) + nil + #'swiper--face-matcher)) + (setq ivy--old-re nil)) + +(defun swiper--face-matcher (regexp candidates) + "Return REGEXP matching CANDIDATES. +Matched candidates should have `swiper-invocation-face'." + (cl-remove-if-not + (lambda (x) + (and (string-match regexp x) + (let* ((s (match-string 0 x)) + (n (length s)) + (i 0)) + (while (and (< i n) + (text-property-any + i (1+ i) + 'face swiper-invocation-face + s)) + (cl-incf i)) + (= i n)))) + candidates)) + +(defun swiper--ensure-visible () + "Remove overlays hiding point." + (let ((overlays (overlays-at (1- (point)))) + ov expose) + (while (setq ov (pop overlays)) + (if (and (invisible-p (overlay-get ov 'invisible)) + (setq expose (overlay-get ov 'isearch-open-invisible))) + (funcall expose ov))))) + +(defvar swiper--overlays nil + "Store overlays.") + +(defvar swiper--isearch-highlight-timer nil + "This timer used by `swiper--delayed-add-overlays'.") + +(defun swiper--cleanup () + "Clean up the overlays." + (while swiper--overlays + (delete-overlay (pop swiper--overlays))) + ;; force cleanup unless it's :unwind + (lazy-highlight-cleanup + (if (eq ivy-exit 'done) lazy-highlight-cleanup t)) + (when (timerp swiper--isearch-highlight-timer) + (cancel-timer swiper--isearch-highlight-timer) + (setq swiper--isearch-highlight-timer nil))) + +(defun swiper--add-cursor-overlay (wnd) + (let* ((special (or (eolp) (looking-at "\t"))) + (ov (make-overlay (point) (if special (point) (1+ (point)))))) + (if special + (overlay-put ov 'after-string (propertize " " 'face 'ivy-cursor)) + (overlay-put ov 'face 'ivy-cursor)) + (overlay-put ov 'window wnd) + (overlay-put ov 'priority 2) + (push ov swiper--overlays))) + +(defun swiper--add-line-overlay (wnd) + (let ((beg (if visual-line-mode + (save-excursion + (beginning-of-visual-line) + (point)) + (line-beginning-position))) + (end (if visual-line-mode + (save-excursion + (end-of-visual-line) + (point)) + (1+ (line-end-position))))) + (push (swiper--make-overlay beg end 'swiper-line-face wnd 0) + swiper--overlays))) + +(defun swiper--make-overlay (beg end face wnd priority) + "Create an overlay bound by BEG and END. +FACE, WND and PRIORITY are properties corresponding to +the face, window and priority of the overlay." + (let ((overlay (make-overlay beg end))) + (overlay-put overlay 'face face) + (overlay-put overlay 'window wnd) + (overlay-put overlay 'priority priority) + overlay)) + +(defun swiper--recenter-p () + (or (display-graphic-p) + (not recenter-redisplay))) + +(defun swiper--update-input-ivy () + "Called when `ivy' input is updated." + (with-ivy-window + (swiper--cleanup) + (when (> (length (ivy-state-current ivy-last)) 0) + (let ((regexps (ivy--positive-regexps)) + (re-idx -1) + (case-fold-search (ivy--case-fold-p ivy-text))) + (dolist (re regexps) + (setq re-idx (1+ re-idx)) + (let* ((re (ivy--string-replace " " "\t" re)) + (num (swiper--line-number (ivy-state-current ivy-last)))) + (unless (memq this-command '(ivy-yank-word + ivy-yank-symbol + ivy-yank-char + scroll-other-window)) + (when (cl-plusp num) + (unless (if swiper--current-line + (eq swiper--current-line num) + (eq (line-number-at-pos) num)) + (goto-char swiper--point-min) + (if swiper-use-visual-line + (line-move (1- num)) + (forward-line (1- num)))) + (if (and (equal ivy-text "") + (<= (line-beginning-position) + swiper--opoint + (line-end-position))) + (goto-char swiper--opoint) + (if (eq swiper--current-line num) + (when swiper--current-match-start + (goto-char swiper--current-match-start)) + (setq swiper--current-line num)) + (when (re-search-forward re (line-end-position) t) + (setq swiper--current-match-start (match-beginning 0)))) + (funcall isearch-filter-predicate + (line-beginning-position) + (line-end-position)) + (swiper--maybe-recenter))) + (swiper--add-overlays + re + (max + (if (swiper--recenter-p) + (window-start) + (line-beginning-position (- (window-height)))) + swiper--point-min) + (min + (if (swiper--recenter-p) + (window-end (selected-window) t) + (line-end-position (window-height))) + swiper--point-max) + nil + re-idx))))))) + +(defun swiper--add-overlays (re &optional beg end wnd re-idx) + "Add overlays for RE regexp in visible part of the current buffer. +BEG and END, when specified, are the point bounds. +WND, when specified is the window." + (setq wnd (or wnd (ivy-state-window ivy-last))) + (swiper--add-line-overlay wnd) + (let* ((pt (point)) + (wh (window-height)) + (beg (or beg (save-excursion + (forward-line (- wh)) + (point)))) + (end (or end (save-excursion + (forward-line wh) + (point)))) + (case-fold-search (ivy--case-fold-p re))) + (when (>= (length re) swiper-min-highlight) + (save-excursion + (goto-char beg) + ;; RE can become an invalid regexp + (while (progn + (when (eolp) + (unless (eobp) + (forward-char))) + (and (ignore-errors (re-search-forward re end t)) + (> (- (match-end 0) (match-beginning 0)) 0))) + ;; Don't highlight a match if it spans multiple + ;; lines. `count-lines' returns 1 if the match is within a + ;; single line, even if it includes the newline, and 2 or + ;; greater otherwise. We hope that the inclusion of the + ;; newline will not ever be a problem in practice. + (when (< (count-lines (match-beginning 0) (match-end 0)) 2) + (let* ((faces (if (= (match-end 0) pt) + swiper-faces + swiper-background-faces)) + (adder-fn (lambda (beg end face priority) + (push (swiper--make-overlay beg end face wnd priority) + isearch-lazy-highlight-overlays)))) + (unless (and (consp ivy--old-re) + (null + (save-match-data + (ivy--re-filter ivy--old-re + (list + (buffer-substring-no-properties + (line-beginning-position) + (line-end-position))))))) + (swiper--add-properties faces adder-fn re-idx))))))))) + +(defun swiper--add-properties (faces adder-fn &optional re-idx) + (let ((mb (match-beginning 0)) + (me (match-end 0))) + (unless (> (- me mb) 2017) + (funcall adder-fn + mb me + (if (and ivy-use-group-face-if-no-groups (zerop ivy--subexps)) + (nth (1+ (mod (or re-idx 0) (1- (length faces)))) faces) + (car faces)) + 0))) + (let ((i 1) + (j 0)) + (while (<= (cl-incf j) ivy--subexps) + (let ((bm (match-beginning j)) + (em (match-end j))) + (when (and (integerp em) + (integerp bm)) + (when (eq (ivy-alist-setting ivy-re-builders-alist t) #'ivy--regex-fuzzy) + (while (and (< j ivy--subexps) + (integerp (match-beginning (+ j 1))) + (= em (match-beginning (+ j 1)))) + (setq em (match-end (cl-incf j))))) + (funcall adder-fn + bm em + (nth (1+ (mod (+ i 2) (1- (length faces)))) + faces) + i) + (cl-incf i)))))) + +(defcustom swiper-action-recenter nil + "When non-nil, recenter after exiting `swiper'." + :type 'boolean) +(defvar evil-search-module) +(defvar evil-ex-search-pattern) +(defvar evil-ex-search-persistent-highlight) +(defvar evil-ex-search-direction) +(declare-function evil-ex-search-activate-highlight "ext:evil-search") + +(defun swiper--maybe-recenter () + (cond (swiper-action-recenter + (recenter)) + ((swiper--recenter-p) + (when swiper--current-window-start + (set-window-start (selected-window) swiper--current-window-start)) + (when (or + (< (point) (window-start)) + (> (point) (window-end (ivy-state-window ivy-last) t))) + (recenter)))) + (setq swiper--current-window-start (window-start))) + +(defun swiper--line-number (x) + (or (get-text-property 0 'swiper-line-number x) + (get-text-property 1 'swiper-line-number x))) + +(defcustom swiper-verbose t + "When non-nil, print more informational messages." + :type 'boolean) + +(defun swiper--push-mark () + (when (/= (point) swiper--opoint) + (unless (and transient-mark-mode mark-active) + (when (eq ivy-exit 'done) + (push-mark swiper--opoint t) + (when swiper-verbose + (message "Mark saved where search started")))))) + +(defun swiper--action (x) + "Goto line X." + (let ((ln (1- (swiper--line-number x))) + (re (ivy--regex ivy-text)) + (case-fold-search (ivy--case-fold-p ivy-text))) + (if (null x) + (user-error "No candidates") + (with-ivy-window + (unless (equal (current-buffer) + (ivy-state-buffer ivy-last)) + (switch-to-buffer (ivy-state-buffer ivy-last))) + (goto-char + (if (buffer-narrowed-p) + swiper--point-min + (point-min))) + (funcall (if swiper-use-visual-line + #'line-move + #'forward-line) + ln) + (when (and (re-search-forward re (line-end-position) t) + swiper-goto-start-of-match) + (goto-char (match-beginning 0))) + (swiper--ensure-visible) + (swiper--maybe-recenter) + (swiper--push-mark) + (swiper--remember-search-history re))))) + +(defun swiper--remember-search-history (re) + "Add the search pattern RE to the search history ring." + (add-to-history + 'regexp-search-ring + re + regexp-search-ring-max) + ;; integration with evil-mode's search + (when (bound-and-true-p evil-mode) + (when (eq evil-search-module 'isearch) + (setq isearch-string ivy-text)) + (when (eq evil-search-module 'evil-search) + (add-to-history 'evil-ex-search-history re) + (setq evil-ex-search-pattern (list re t t)) + (setq evil-ex-search-direction 'forward) + (when evil-ex-search-persistent-highlight + (evil-ex-search-activate-highlight evil-ex-search-pattern))))) + +(defun swiper-from-isearch () + "Invoke `swiper' from isearch." + (interactive) + (swiper (prog1 (if isearch-regexp + isearch-string + (regexp-quote isearch-string)) + (let ((search-nonincremental-instead nil)) + (isearch-exit))))) + +(defvar swiper-multi-buffers nil + "Store the current list of buffers.") + +(defvar swiper-multi-candidates nil + "Store the list of candidates for `swiper-multi'.") + +(defun swiper-multi-prompt () + "Return prompt for `swiper-multi'." + (format "Buffers (%s): " + (mapconcat #'identity swiper-multi-buffers ", "))) + +(defvar swiper-window-width 80) + +(defun swiper-multi () + "Select one or more buffers. +Run `swiper' for those buffers." + (interactive) + (setq swiper-multi-buffers nil) + (let ((ivy-use-virtual-buffers nil)) + (ivy-read (swiper-multi-prompt) + #'internal-complete-buffer + :action #'swiper-multi-action-1)) + (let ((swiper-window-width (- (- (frame-width) (if (display-graphic-p) 0 1)) 4))) + (ivy-read "Swiper: " swiper-multi-candidates + :action #'swiper-multi-action-2 + :caller 'swiper-multi))) + +(ivy-configure 'swiper-multi + :unwind-fn #'swiper--cleanup + :index-fn #'ivy-recompute-index-swiper + :format-fn #'swiper--all-format-function) + +(defun swiper-multi-action-1 (x) + "Add X to list of selected buffers `swiper-multi-buffers'. +If X is already part of the list, remove it instead. Quit the selection if +X is selected by either `ivy-done', `ivy-alt-done' or `ivy-immediate-done', +otherwise continue prompting for buffers." + (if (member x swiper-multi-buffers) + (progn + (setq swiper-multi-buffers (delete x swiper-multi-buffers))) + (unless (equal x "") + (setq swiper-multi-buffers (append swiper-multi-buffers (list x))))) + (let ((prompt (swiper-multi-prompt))) + (setf (ivy-state-prompt ivy-last) prompt) + (setq ivy--prompt (concat "%-4d " prompt))) + (cond ((memq this-command '(ivy-done + ivy-alt-done + ivy-immediate-done)) + (setq swiper-multi-candidates + (swiper--multi-candidates + (mapcar #'get-buffer swiper-multi-buffers)))) + ((eq this-command 'ivy-call) + (with-selected-window (active-minibuffer-window) + (delete-minibuffer-contents))))) + +(defun swiper-multi-action-2 (x) + "Move to candidate X from `swiper-multi'." + (when (> (length x) 0) + (let ((buffer-name (get-text-property 0 'buffer x))) + (when buffer-name + (with-ivy-window + (switch-to-buffer buffer-name) + (goto-char (point-min)) + (forward-line (1- (swiper--line-number x))) + (re-search-forward + (ivy--regex ivy-text) + (line-end-position) t) + (funcall isearch-filter-predicate + (line-beginning-position) + (line-end-position)) + (unless (eq ivy-exit 'done) + (swiper--cleanup) + (swiper--add-overlays (ivy--regex ivy-text)))))))) + +(defun swiper-all-buffer-p (buffer) + "Return non-nil if BUFFER should be considered by `swiper-all'." + (let ((mode (buffer-local-value 'major-mode (get-buffer buffer)))) + (cond + ;; Ignore TAGS buffers, they tend to add duplicate results. + ((eq mode #'tags-table-mode) nil) + ;; Always consider dired buffers, even though they're not backed + ;; by a file. + ((eq mode #'dired-mode) t) + ;; Always consider stash buffers too, as they may have + ;; interesting content not present in any buffers. We don't #' + ;; quote to satisfy the byte-compiler. + ((eq mode 'magit-stash-mode) t) + ;; Email buffers have no file, but are useful to search + ((eq mode 'gnus-article-mode) t) + ;; Otherwise, only consider the file if it's backed by a file. + (t (buffer-file-name buffer))))) + +;;; `swiper-all' + +(defun swiper-all-function (str) + "Search in all open buffers for STR." + (or + (ivy-more-chars) + (let* ((buffers (cl-delete-if-not #'swiper-all-buffer-p (buffer-list))) + (re-full ivy-regex) + re re-tail + cands match + (case-fold-search (ivy--case-fold-p str))) + (setq re (ivy-re-to-str re-full)) + (when (consp re-full) + (setq re-tail (cdr re-full))) + (dolist (buffer buffers) + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (while (re-search-forward re nil t) + (setq match (if (memq major-mode '(org-mode dired-mode)) + (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)) + (buffer-substring + (line-beginning-position) + (line-end-position)))) + (put-text-property + 0 1 'buffer + (buffer-name) + match) + (put-text-property 0 1 'point (point) match) + (when (or (null re-tail) (ivy-re-match re-tail match)) + (push match cands)))))) + (setq ivy--old-re re-full) + (if (null cands) + (list "") + (setq ivy--old-cands (nreverse cands)))))) + +(defun swiper--all-format-function (cands) + "Format CANDS for `swiper-all'. +See `ivy-format-functions-alist' for further information." + (let* ((ww swiper-window-width) + (col2 1) + (cands-with-buffer + (mapcar (lambda (s) + (let ((buffer (get-text-property 0 'buffer s))) + (setq col2 (max col2 (length buffer))) + (cons s buffer))) cands)) + (col1 (- ww 4 col2))) + (setq cands + (mapcar (lambda (x) + (if (cdr x) + (let ((s (ivy--truncate-string (car x) col1))) + (concat + s + (make-string + (max 0 + (- ww (string-width s) (length (cdr x)))) + ?\ ) + (cdr x))) + (car x))) + cands-with-buffer)) + (ivy--format-function-generic + (lambda (str) + (ivy--add-face str 'ivy-current-match)) + (lambda (str) + str) + cands + "\n"))) + +(defvar swiper-all-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "M-q") #'swiper-all-query-replace) + map) + "Keymap for `swiper-all'.") + +;;;###autoload +(defun swiper-all (&optional initial-input) + "Run `swiper' for all open buffers." + (interactive) + (let ((swiper-window-width (- (frame-width) (if (display-graphic-p) 0 1)))) + (ivy-read "swiper-all: " 'swiper-all-function + :action #'swiper-all-action + :dynamic-collection t + :keymap swiper-all-map + :initial-input initial-input + :caller 'swiper-all))) + +(ivy-configure 'swiper-all + :update-fn 'auto + :unwind-fn #'swiper--cleanup + :format-fn #'swiper--all-format-function) + +(defun swiper-all-action (x) + "Move to candidate X from `swiper-all'." + (when (> (length x) 0) + (let ((buffer-name (get-text-property 0 'buffer x))) + (when buffer-name + (with-ivy-window + (switch-to-buffer buffer-name) + (goto-char (get-text-property 0 'point x)) + (funcall isearch-filter-predicate + (line-beginning-position) + (line-end-position)) + (unless (eq ivy-exit 'done) + (swiper--cleanup) + (swiper--add-overlays (ivy--regex ivy-text)))))))) + +(defun swiper--multi-candidates (buffers) + "Extract candidates from BUFFERS." + (let ((res nil)) + (dolist (buf buffers) + (with-current-buffer buf + (setq res + (nconc + (mapcar + (lambda (s) (put-text-property 0 1 'buffer (buffer-name) s) s) + (swiper--candidates 4)) + res)))) + res)) + +;;; `swiper-isearch' + +(defun swiper-isearch-function (str) + "Collect STR matches in the current buffer for `swiper-isearch'." + (with-ivy-window + (swiper--isearch-function str))) + +(defun swiper-match-usable-p () + (or search-invisible + (not (cl-find-if + (lambda (ov) + (invisible-p (overlay-get ov 'invisible))) + (overlays-at (point)))))) + +(defvar swiper--isearch-backward nil + "Non-nil when performing `swiper-isearch-backward'.") + +(defun swiper--isearch-function-1 (re backward) + (unless (string= re ".") + (let (cands) + (save-excursion + (goto-char (if backward (point-max) (point-min))) + (while (and (funcall (if backward #'re-search-backward #'re-search-forward) re nil t) + (not (and + (= (match-beginning 0) (match-end 0)) + (if backward (bobp) (eobp))))) + (when (swiper-match-usable-p) + (let ((pos (if (or backward swiper-goto-start-of-match) + (match-beginning 0) + (point)))) + (push pos cands))) + (when (= (match-beginning 0) (match-end 0)) + (if backward + (backward-char) + (forward-char))))) + (if backward + cands + (nreverse cands))))) + +(defun swiper--isearch-next-item (re cands) + (or (if swiper--isearch-backward + (save-excursion + ;; Match RE starting at each position in CANDS. + (setq re (concat "\\=\\(?:" re "\\)")) + (cl-position-if + (lambda (x) + (when (< x swiper--opoint) + (goto-char x) + ;; Note: Not quite the same as `looking-at' + `match-end'. + (re-search-forward re swiper--opoint t))) + cands + :from-end t)) + (cl-position swiper--opoint cands :test #'<)) + 0)) + +(defun swiper--isearch-filter-ignore-order (re-full cands) + (let (filtered-cands) + (dolist (re-cons re-full cands) + (save-excursion + (dolist (cand cands) + (goto-char cand) + (beginning-of-line) + (unless (if (re-search-forward (car re-cons) (line-end-position) t) + (not (cdr re-cons)) + (cdr re-cons)) + (push cand filtered-cands)))) + (setq cands (nreverse filtered-cands)) + (setq filtered-cands nil)))) + +(defun swiper--isearch-function (str) + (let ((re-full ivy-regex)) + (unless (equal re-full "") + (let* ((case-fold-search (ivy--case-fold-p str)) + (re + (if (stringp re-full) + re-full + (mapconcat + #'ivy--regex-or-literal + (delq nil (mapcar (lambda (x) (and (cdr x) (car x))) re-full)) + "\\|"))) + (cands (swiper--isearch-function-1 re swiper--isearch-backward))) + (when (consp re-full) + (setq cands (swiper--isearch-filter-ignore-order re-full cands))) + (setq ivy--old-re re) + (ivy-set-index (swiper--isearch-next-item re cands)) + (setq ivy--old-cands cands))))) + +(defcustom swiper-isearch-highlight-delay '(2 0.2) + "When `ivy-text' is too short, delay showing the overlay. + +The default value will delay showing the overlay by 0.2 seconds +if `ivy-text' is shorter than 2 characters. + +The aim is to reduce the visual clutter, since it's very rare +that we search only for one character." + :type '(list + (integer :tag "Text length") + (float :tag "Delay in seconds"))) + +(defun swiper--delayed-add-overlays () + (if (and swiper-isearch-highlight-delay + (< (length ivy-text) (car swiper-isearch-highlight-delay))) + (setq swiper--isearch-highlight-timer + (run-with-idle-timer + (cadr swiper-isearch-highlight-delay) nil + (lambda () + (with-ivy-window + (swiper--add-overlays (ivy--regex ivy-text)))))) + (dolist (re (ivy--positive-regexps)) + (swiper--add-overlays re)))) + +(defun swiper--isearch-candidate-pos (cand) + "Return the buffer position of `swiper-isearch' CAND, or nil." + (cond ((integer-or-marker-p cand) cand) + ((and (stringp cand) (> (length cand) 0)) + (get-text-property 0 'point cand)))) + +(defun swiper--isearch-candidate-string (cand) + "Return full match of `swiper-isearch' candidate CAND. +Signal an error on failure." + ;; FIXME: Better way of getting current candidate? + (or (let ((pos (swiper--isearch-candidate-pos cand)) + (re (ivy-re-to-str ivy-regex))) + (save-match-data + (save-excursion + (and pos (goto-char pos) + (if (or swiper--isearch-backward swiper-goto-start-of-match) + (looking-at re) + (looking-back re (point-min))) + (match-string 0))))) + (error "Could not extract `swiper-isearch' candidate: %S" cand))) + +(defun swiper-isearch-action (x) + "Move to X for `swiper-isearch'." + (if (setq x (swiper--isearch-candidate-pos x)) + (with-ivy-window + (goto-char x) + (when (and (or (eq this-command 'ivy-previous-line-or-history) + (and (eq this-command 'ivy-done) + (eq last-command 'ivy-previous-line-or-history))) + (looking-back ivy-regex (line-beginning-position))) + (goto-char (match-beginning 0))) + (funcall isearch-filter-predicate (point) (1+ (point))) + (swiper--maybe-recenter) + (if (or (eq ivy-exit 'done) + ;; FIXME: With the default action 'M-o o', `ivy-exit' remains + ;; nil for some reason, so check `this-command' instead to + ;; tell whether we're "done". + (eq this-command #'ivy-dispatching-done)) + (progn + (swiper--push-mark) + (swiper--remember-search-history (ivy--regex ivy-text))) + (swiper--cleanup) + (swiper--delayed-add-overlays) + (swiper--add-cursor-overlay + (ivy-state-window ivy-last)))) + (swiper--cleanup))) + +(defun swiper-action-copy (_x) + "Copy line at point and go back." + (kill-new + (buffer-substring-no-properties + (line-beginning-position) (line-end-position))) + (goto-char swiper--opoint)) + +(defun swiper-isearch-action-copy (cand) + "Save `swiper-isearch' candidate CAND to `kill-ring'. +Return to original position." + (unwind-protect + (kill-new (swiper--isearch-candidate-string cand)) + ;; In case of unexpected error. + (goto-char swiper--opoint))) + +(defun swiper-isearch-action-insert (cand) + "Insert `swiper-isearch' candidate CAND where invoked. +This cannot currently be called repeatedly without exiting +completion." + (goto-char swiper--opoint) + (unwind-protect + ;; FIXME: This seems to invalidate many cached buffer positions, thus + ;; breaking `ivy-dispatching-call'. + (insert (swiper--isearch-candidate-string cand)) + ;; In case of unexpected error. + (goto-char swiper--opoint))) + +(defun swiper--isearch-insert-current () + "Replace minibuffer contents with the current candidate. +Like `ivy-insert-current', but tailored for `swiper-isearch'." + (interactive) + (delete-minibuffer-contents) + (let ((cur (ivy-state-current ivy-last))) + (insert (with-ivy-window (swiper--isearch-candidate-string cur))))) + +(defun swiper--isearch-kill-ring-save () + "Save the current candidates in the kill ring. +If the region is active, forward to `kill-ring-save' instead. +Like `ivy-kill-ring-save', but tailored for `swiper-isearch'." + (interactive) + (if (use-region-p) + (call-interactively #'kill-ring-save) + (kill-new (with-ivy-window + (mapconcat #'swiper--line-at-point ivy--old-cands "\n"))))) + +(defun swiper-isearch-thing-at-point () + "Insert `symbol-at-point' into the minibuffer of `swiper-isearch'. +When not running `swiper-isearch' already, start it." + (interactive) + (if (window-minibuffer-p) + (let (bnd str regionp) + (with-ivy-window + (setq bnd + (if (setq regionp (region-active-p)) + (prog1 (cons (region-beginning) (region-end)) + (deactivate-mark)) + (bounds-of-thing-at-point 'symbol))) + (setq str (buffer-substring-no-properties (car bnd) (cdr bnd)))) + (insert str) + (unless regionp + (ivy--insert-symbol-boundaries))) + (let (thing) + (if (use-region-p) + (progn + (setq thing (buffer-substring-no-properties + (region-beginning) (region-end))) + (goto-char (region-beginning)) + (deactivate-mark)) + (let ((bnd (bounds-of-thing-at-point 'symbol))) + (when bnd + (goto-char (car bnd))) + (setq thing (ivy-thing-at-point)))) + (swiper-isearch thing)))) + +(defun swiper-isearch-C-r (&optional arg) + "Move cursor vertically up ARG candidates. +When the input is empty, browse the search history instead." + (interactive "p") + (if (string= ivy-text "") + (ivy-reverse-i-search) + (ivy-previous-line arg))) + +(defvar swiper-isearch-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map swiper-map) + (define-key map `[remap ,#'ivy-insert-current] + #'swiper--isearch-insert-current) + (define-key map `[remap ,#'ivy-kill-ring-save] + #'swiper--isearch-kill-ring-save) + (define-key map `[remap ,#'kill-ring-save] + #'swiper--isearch-kill-ring-save) + (define-key map (kbd "M-n") #'swiper-isearch-thing-at-point) + (define-key map (kbd "C-r") #'swiper-isearch-C-r) + map) + "Keymap for `swiper-isearch'.") + +(defun swiper--isearch-same-line-p (s1 s2) + "Check if S1 and S2 are equal and on the same line." + (and (equal s1 s2) + (<= (count-lines + (get-text-property 0 'point s2) + (get-text-property 0 'point s1)) + 1))) + +(defun swiper-isearch-format-function (cands) + (if (numberp (car-safe cands)) + (let ((re (ivy-re-to-str ivy-regex))) + (if (string= re "^$") + "" + (mapconcat + #'identity + (swiper--isearch-format + ivy--index ivy--length (or ivy--old-cands ivy--all-candidates) + re + (ivy-state-current ivy-last) + (ivy-state-buffer ivy-last)) + "\n"))) + (funcall + (ivy-alist-setting ivy-format-functions-alist t) + cands))) + +(defun swiper--line-at-point (pt) + (save-excursion + (goto-char pt) + (let ((s (buffer-substring + (line-beginning-position) + (line-end-position)))) + (if (string= s "") + s + (put-text-property 0 1 'point pt s) + (ivy-cleanup-string s))))) + +(defun swiper--isearch-highlight (str &optional current) + (let ((start 0) + (i 0) + (re (ivy-re-to-str ivy-regex))) + (catch 'done + (while (string-match re str start) + (if (= (match-beginning 0) (match-end 0)) + (throw 'done t) + (setq start (match-end 0))) + (swiper--add-properties + (if (eq current i) + swiper-faces + swiper-background-faces) + (lambda (beg end face _priority) + (add-face-text-property beg end face nil str))) + (cl-incf i))) + str)) + +(defun swiper--isearch-format (index length cands regex current buffer) + (let* ((half-height (/ ivy-height 2)) + (i (1- index)) + (j 0) + (len 0) + res s) + (with-current-buffer buffer + (while (and (>= i 0) + (swiper--isearch-same-line-p + (swiper--line-at-point (nth i cands)) + (swiper--line-at-point current))) + (cl-decf i) + (cl-incf j)) + (while (and (>= i 0) + (< len half-height)) + (setq s (swiper--line-at-point (nth i cands))) + (unless (swiper--isearch-same-line-p s (car res)) + (push (swiper--isearch-highlight s) res) + (cl-incf len)) + (cl-decf i)) + (setq res (nreverse res)) + (let ((current-str + (swiper--line-at-point current)) + (start 0)) + (dotimes (_ (1+ j)) + (string-match regex current-str start) + (setq start (match-end 0))) + (font-lock-prepend-text-property + 0 (length current-str) + 'face 'swiper-line-face current-str) + (swiper--isearch-highlight current-str j) + (push current-str res)) + (cl-incf len) + (setq i (1+ index)) + (while (and (< i length) + (swiper--isearch-same-line-p + (swiper--line-at-point (nth i cands)) + (swiper--line-at-point current))) + (cl-incf i)) + (while (and (< i length) + (< len ivy-height)) + (setq s (swiper--line-at-point (nth i cands))) + (unless (swiper--isearch-same-line-p s (car res)) + (push (swiper--isearch-highlight s) res) + (cl-incf len)) + (cl-incf i)) + (nreverse res)))) + +(defun swiper--isearch-init () + "Initialize `swiper-isearch'." + (swiper--init) + (swiper-font-lock-ensure)) + +(defun swiper--isearch-unwind () + (swiper--cleanup) + (unless (or (eq ivy-exit 'done) swiper-stay-on-quit) + (goto-char swiper--opoint)) + (isearch-clean-overlays) + (swiper--ensure-visible) + (unless (or (eq ivy-exit 'done) (string= ivy-text "")) + (cl-pushnew ivy-text swiper-history))) + +;;;###autoload +(defun swiper-isearch (&optional initial-input) + "A `swiper' that's not line-based." + (interactive) + (let ((ivy-fixed-height-minibuffer t) + (cursor-in-non-selected-windows nil) + (swiper-min-highlight 1)) + (ivy-read + "Swiper: " + #'swiper-isearch-function + :initial-input initial-input + :keymap swiper-isearch-map + :dynamic-collection t + :require-match t + :action #'swiper-isearch-action + :re-builder #'swiper--re-builder + :history 'swiper-history + :extra-props (list :fname (buffer-file-name)) + :caller 'swiper-isearch))) + +(ivy-configure 'swiper-isearch + :occur #'swiper-occur + :init-fn #'swiper--isearch-init + :update-fn 'auto + :unwind-fn #'swiper--isearch-unwind + :format-fn #'swiper-isearch-format-function) + +(ivy-add-actions 'swiper-isearch + `(("w" ,#'swiper-isearch-action-copy "copy") + ("i" ,#'swiper-isearch-action-insert "insert"))) + +;;;###autoload +(defun swiper-isearch-backward (&optional initial-input) + "Like `swiper-isearch' but the first result is before the point." + (interactive) + (let ((swiper--isearch-backward t)) + (swiper-isearch initial-input))) + +(defun swiper-isearch-toggle () + "Two-way toggle between `swiper-isearch' and isearch. +Intended to be bound in `isearch-mode-map' and `swiper-map'." + (interactive) + (if isearch-mode + (let ((query (if isearch-regexp + isearch-string + (regexp-quote isearch-string)))) + (isearch-exit) + (goto-char (or (and isearch-forward isearch-other-end) + (point))) + (swiper-isearch query)) + (ivy-exit-with-action + (lambda (_) + (when (looking-back (ivy-re-to-str ivy-regex) (line-beginning-position)) + (goto-char (match-beginning 0))) + (isearch-mode t) + (unless (string= ivy-text "") + (isearch-yank-string ivy-text)))))) + +(provide 'swiper) + +;;; swiper.el ends here diff --git a/.emacs.d/lisp/undo-tree.el b/.emacs.d/lisp/undo-tree.el new file mode 100644 index 0000000..e345d4c --- /dev/null +++ b/.emacs.d/lisp/undo-tree.el @@ -0,0 +1,4767 @@ +;;; undo-tree.el --- Treat undo history as a tree -*- lexical-binding: t; -*- + +;; Copyright (C) 2009-2021 Free Software Foundation, Inc + +;; Author: Toby Cubitt +;; Maintainer: Toby Cubitt +;; Version: 0.8.2 +;; Keywords: convenience, files, undo, redo, history, tree +;; Package-Requires: ((queue "0.2")) +;; URL: https://www.dr-qubit.org/undo-tree.html +;; Repository: https://gitlab.com/tsc25/undo-tree + +;; This file is part of Emacs. +;; +;; This file is free software: you can redistribute it and/or modify it under +;; the terms of the GNU General Public License as published by the Free +;; Software Foundation, either version 3 of the License, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for +;; more details. +;; +;; You should have received a copy of the GNU General Public License along +;; with GNU Emacs. If not, see . + + +;;; Commentary: +;; +;; Emacs has a powerful undo system. Unlike the standard undo/redo system in +;; most software, it allows you to recover *any* past state of a buffer +;; (whereas the standard undo/redo system can lose past states as soon as you +;; redo). However, this power comes at a price: many people find Emacs' undo +;; system confusing and difficult to use, spawning a number of packages that +;; replace it with the less powerful but more intuitive undo/redo system. +;; +;; Both the loss of data with standard undo/redo, and the confusion of Emacs' +;; undo, stem from trying to treat undo history as a linear sequence of +;; changes. It's not. The `undo-tree-mode' provided by this package replaces +;; Emacs' undo system with a system that treats undo history as what it is: a +;; branching tree of changes. This simple idea allows the more intuitive +;; behaviour of the standard undo/redo system to be combined with the power of +;; never losing any history. An added side bonus is that undo history can in +;; some cases be stored more efficiently, allowing more changes to accumulate +;; before Emacs starts discarding history. +;; +;; The only downside to this more advanced yet simpler undo system is that it +;; was inspired by Vim. But, after all, most successful religions steal the +;; best ideas from their competitors! +;; +;; +;; Installation +;; ============ +;; +;; This package has only been tested with Emacs versions 24 and CVS. It should +;; work in Emacs versions 22 and 23 too, but will not work without +;; modifications in earlier versions of Emacs. +;; +;; To install `undo-tree-mode', make sure this file is saved in a directory in +;; your `load-path', and add the line: +;; +;; (require 'undo-tree) +;; +;; to your .emacs file. Byte-compiling undo-tree.el is recommended (e.g. using +;; "M-x byte-compile-file" from within emacs). +;; +;; If you want to replace the standard Emacs' undo system with the +;; `undo-tree-mode' system in all buffers, you can enable it globally by +;; adding: +;; +;; (global-undo-tree-mode) +;; +;; to your .emacs file. +;; +;; +;; Quick-Start +;; =========== +;; +;; If you're the kind of person who likes to jump in the car and drive, +;; without bothering to first figure out whether the button on the left dips +;; the headlights or operates the ejector seat (after all, you'll soon figure +;; it out when you push it), then here's the minimum you need to know: +;; +;; `undo-tree-mode' and `global-undo-tree-mode' +;; Enable undo-tree mode (either in the current buffer or globally). +;; +;; C-_ C-/ (`undo-tree-undo') +;; Undo changes. +;; +;; M-_ C-? (`undo-tree-redo') +;; Redo changes. +;; +;; `undo-tree-switch-branch' +;; Switch undo-tree branch. +;; (What does this mean? Better press the button and see!) +;; +;; C-x u (`undo-tree-visualize') +;; Visualize the undo tree. +;; (Better try pressing this button too!) +;; +;; C-x r u (`undo-tree-save-state-to-register') +;; Save current buffer state to register. +;; +;; C-x r U (`undo-tree-restore-state-from-register') +;; Restore buffer state from register. +;; +;; +;; +;; In the undo-tree visualizer: +;; +;; p C-p (`undo-tree-visualize-undo') +;; Undo changes. +;; +;; n C-n (`undo-tree-visualize-redo') +;; Redo changes. +;; +;; b C-b (`undo-tree-visualize-switch-branch-left') +;; Switch to previous undo-tree branch. +;; +;; f C-f (`undo-tree-visualize-switch-branch-right') +;; Switch to next undo-tree branch. +;; +;; C- M-{ (`undo-tree-visualize-undo-to-x') +;; Undo changes up to last branch point. +;; +;; C- M-} (`undo-tree-visualize-redo-to-x') +;; Redo changes down to next branch point. +;; +;; n C-n (`undo-tree-visualize-redo') +;; Redo changes. +;; +;; (`undo-tree-visualizer-mouse-set') +;; Set state to node at mouse click. +;; +;; t (`undo-tree-visualizer-toggle-timestamps') +;; Toggle display of time-stamps. +;; +;; d (`undo-tree-visualizer-toggle-diff') +;; Toggle diff display. +;; +;; s (`undo-tree-visualizer-selection-mode') +;; Toggle keyboard selection mode. +;; +;; q (`undo-tree-visualizer-quit') +;; Quit undo-tree-visualizer. +;; +;; C-q (`undo-tree-visualizer-abort') +;; Abort undo-tree-visualizer. +;; +;; , < +;; Scroll left. +;; +;; . > +;; Scroll right. +;; +;; M-v +;; Scroll up. +;; +;; C-v +;; Scroll down. +;; +;; +;; +;; In visualizer selection mode: +;; +;; p C-p (`undo-tree-visualizer-select-previous') +;; Select previous node. +;; +;; n C-n (`undo-tree-visualizer-select-next') +;; Select next node. +;; +;; b C-b (`undo-tree-visualizer-select-left') +;; Select left sibling node. +;; +;; f C-f (`undo-tree-visualizer-select-right') +;; Select right sibling node. +;; +;; M-v +;; Select node 10 above. +;; +;; C-v +;; Select node 10 below. +;; +;; (`undo-tree-visualizer-set') +;; Set state to selected node and exit selection mode. +;; +;; s (`undo-tree-visualizer-mode') +;; Exit selection mode. +;; +;; t (`undo-tree-visualizer-toggle-timestamps') +;; Toggle display of time-stamps. +;; +;; d (`undo-tree-visualizer-toggle-diff') +;; Toggle diff display. +;; +;; q (`undo-tree-visualizer-quit') +;; Quit undo-tree-visualizer. +;; +;; C-q (`undo-tree-visualizer-abort') +;; Abort undo-tree-visualizer. +;; +;; , < +;; Scroll left. +;; +;; . > +;; Scroll right. +;; +;; +;; +;; Persistent undo history: +;; +;; Note: Requires Emacs version 24.3 or higher. +;; +;; `undo-tree-auto-save-history' (variable) +;; automatically save and restore undo-tree history along with buffer +;; (disabled by default) +;; +;; `undo-tree-save-history' (command) +;; manually save undo history to file +;; +;; `undo-tree-load-history' (command) +;; manually load undo history from file +;; +;; +;; +;; Compressing undo history: +;; +;; Undo history files cannot grow beyond the maximum undo tree size, which +;; is limited by `undo-limit', `undo-strong-limit' and +;; `undo-outer-limit'. Nevertheless, undo history files can grow quite +;; large. If you want to automatically compress undo history, add the +;; following advice to your .emacs file (replacing ".gz" with the filename +;; extension of your favourite compression algorithm): +;; +;; (defadvice undo-tree-make-history-save-file-name +;; (after undo-tree activate) +;; (setq ad-return-value (concat ad-return-value ".gz"))) +;; +;; +;; +;; +;; Undo Systems +;; ============ +;; +;; To understand the different undo systems, it's easiest to consider an +;; example. Imagine you make a few edits in a buffer. As you edit, you +;; accumulate a history of changes, which we might visualize as a string of +;; past buffer states, growing downwards: +;; +;; o (initial buffer state) +;; | +;; | +;; o (first edit) +;; | +;; | +;; o (second edit) +;; | +;; | +;; x (current buffer state) +;; +;; +;; Now imagine that you undo the last two changes. We can visualize this as +;; rewinding the current state back two steps: +;; +;; o (initial buffer state) +;; | +;; | +;; x (current buffer state) +;; | +;; | +;; o +;; | +;; | +;; o +;; +;; +;; However, this isn't a good representation of what Emacs' undo system +;; does. Instead, it treats the undos as *new* changes to the buffer, and adds +;; them to the history: +;; +;; o (initial buffer state) +;; | +;; | +;; o (first edit) +;; | +;; | +;; o (second edit) +;; | +;; | +;; x (buffer state before undo) +;; | +;; | +;; o (first undo) +;; | +;; | +;; x (second undo) +;; +;; +;; Actually, since the buffer returns to a previous state after an undo, +;; perhaps a better way to visualize it is to imagine the string of changes +;; turning back on itself: +;; +;; (initial buffer state) o +;; | +;; | +;; (first edit) o x (second undo) +;; | | +;; | | +;; (second edit) o o (first undo) +;; | / +;; |/ +;; o (buffer state before undo) +;; +;; Treating undos as new changes might seem a strange thing to do. But the +;; advantage becomes clear as soon as we imagine what happens when you edit +;; the buffer again. Since you've undone a couple of changes, new edits will +;; branch off from the buffer state that you've rewound to. Conceptually, it +;; looks like this: +;; +;; o (initial buffer state) +;; | +;; | +;; o +;; |\ +;; | \ +;; o x (new edit) +;; | +;; | +;; o +;; +;; The standard undo/redo system only lets you go backwards and forwards +;; linearly. So as soon as you make that new edit, it discards the old +;; branch. Emacs' undo just keeps adding changes to the end of the string. So +;; the undo history in the two systems now looks like this: +;; +;; Undo/Redo: Emacs' undo +;; +;; o o +;; | | +;; | | +;; o o o +;; .\ | |\ +;; . \ | | \ +;; . x (new edit) o o | +;; (discarded . | / | +;; branch) . |/ | +;; . o | +;; | +;; | +;; x (new edit) +;; +;; Now, what if you change your mind about those undos, and decide you did +;; like those other changes you'd made after all? With the standard undo/redo +;; system, you're lost. There's no way to recover them, because that branch +;; was discarded when you made the new edit. +;; +;; However, in Emacs' undo system, those old buffer states are still there in +;; the undo history. You just have to rewind back through the new edit, and +;; back through the changes made by the undos, until you reach them. Of +;; course, since Emacs treats undos (even undos of undos!) as new changes, +;; you're really weaving backwards and forwards through the history, all the +;; time adding new changes to the end of the string as you go: +;; +;; o +;; | +;; | +;; o o o (undo new edit) +;; | |\ |\ +;; | | \ | \ +;; o o | | o (undo the undo) +;; | / | | | +;; |/ | | | +;; (trying to get o | | x (undo the undo) +;; to this state) | / +;; |/ +;; o +;; +;; So far, this is still reasonably intuitive to use. It doesn't behave so +;; differently to standard undo/redo, except that by going back far enough you +;; can access changes that would be lost in standard undo/redo. +;; +;; However, imagine that after undoing as just described, you decide you +;; actually want to rewind right back to the initial state. If you're lucky, +;; and haven't invoked any command since the last undo, you can just keep on +;; undoing until you get back to the start: +;; +;; (trying to get o x (got there!) +;; to this state) | | +;; | | +;; o o o o (keep undoing) +;; | |\ |\ | +;; | | \ | \ | +;; o o | | o o (keep undoing) +;; | / | | | / +;; |/ | | |/ +;; (already undid o | | o (got this far) +;; to this state) | / +;; |/ +;; o +;; +;; But if you're unlucky, and you happen to have moved the point (say) after +;; getting to the state labelled "got this far", then you've "broken the undo +;; chain". Hold on to something solid, because things are about to get +;; hairy. If you try to undo now, Emacs thinks you're trying to undo the +;; undos! So to get back to the initial state you now have to rewind through +;; *all* the changes, including the undos you just did: +;; +;; (trying to get o x (finally got there!) +;; to this state) | | +;; | | +;; o o o o o o +;; | |\ |\ |\ |\ | +;; | | \ | \ | \ | \ | +;; o o | | o o | | o o +;; | / | | | / | | | / +;; |/ | | |/ | | |/ +;; (already undid o | | o<. | | o +;; to this state) | / : | / +;; |/ : |/ +;; o : o +;; : +;; (got this far, but +;; broke the undo chain) +;; +;; Confused? +;; +;; In practice you can just hold down the undo key until you reach the buffer +;; state that you want. But whatever you do, don't move around in the buffer +;; to *check* that you've got back to where you want! Because you'll break the +;; undo chain, and then you'll have to traverse the entire string of undos +;; again, just to get back to the point at which you broke the +;; chain. Undo-in-region and commands such as `undo-only' help to make using +;; Emacs' undo a little easier, but nonetheless it remains confusing for many +;; people. +;; +;; +;; So what does `undo-tree-mode' do? Remember the diagram we drew to represent +;; the history we've been discussing (make a few edits, undo a couple of them, +;; and edit again)? The diagram that conceptually represented our undo +;; history, before we started discussing specific undo systems? It looked like +;; this: +;; +;; o (initial buffer state) +;; | +;; | +;; o +;; |\ +;; | \ +;; o x (current state) +;; | +;; | +;; o +;; +;; Well, that's *exactly* what the undo history looks like to +;; `undo-tree-mode'. It doesn't discard the old branch (as standard undo/redo +;; does), nor does it treat undos as new changes to be added to the end of a +;; linear string of buffer states (as Emacs' undo does). It just keeps track +;; of the tree of branching changes that make up the entire undo history. +;; +;; If you undo from this point, you'll rewind back up the tree to the previous +;; state: +;; +;; o +;; | +;; | +;; x (undo) +;; |\ +;; | \ +;; o o +;; | +;; | +;; o +;; +;; If you were to undo again, you'd rewind back to the initial state. If on +;; the other hand you redo the change, you'll end up back at the bottom of the +;; most recent branch: +;; +;; o (undo takes you here) +;; | +;; | +;; o (start here) +;; |\ +;; | \ +;; o x (redo takes you here) +;; | +;; | +;; o +;; +;; So far, this is just like the standard undo/redo system. But what if you +;; want to return to a buffer state located on a previous branch of the +;; history? Since `undo-tree-mode' keeps the entire history, you simply need +;; to tell it to switch to a different branch, and then redo the changes you +;; want: +;; +;; o +;; | +;; | +;; o (start here, but switch +;; |\ to the other branch) +;; | \ +;; (redo) o o +;; | +;; | +;; (redo) x +;; +;; Now you're on the other branch, if you undo and redo changes you'll stay on +;; that branch, moving up and down through the buffer states located on that +;; branch. Until you decide to switch branches again, of course. +;; +;; Real undo trees might have multiple branches and sub-branches: +;; +;; o +;; ____|______ +;; / \ +;; o o +;; ____|__ __| +;; / | \ / \ +;; o o o o x +;; | | +;; / \ / \ +;; o o o o +;; +;; Trying to imagine what Emacs' undo would do as you move about such a tree +;; will likely frazzle your brain circuits! But in `undo-tree-mode', you're +;; just moving around this undo history tree. Most of the time, you'll +;; probably only need to stay on the most recent branch, in which case it +;; behaves like standard undo/redo, and is just as simple to understand. But +;; if you ever need to recover a buffer state on a different branch, the +;; possibility of switching between branches and accessing the full undo +;; history is still there. +;; +;; +;; +;; The Undo-Tree Visualizer +;; ======================== +;; +;; Actually, it gets better. You don't have to imagine all these tree +;; diagrams, because `undo-tree-mode' includes an undo-tree visualizer which +;; draws them for you! In fact, it draws even better diagrams: it highlights +;; the node representing the current buffer state, it highlights the current +;; branch, and you can toggle the display of time-stamps (by hitting "t") and +;; a diff of the undo changes (by hitting "d"). (There's one other tiny +;; difference: the visualizer puts the most recent branch on the left rather +;; than the right.) +;; +;; Bring up the undo tree visualizer whenever you want by hitting "C-x u". +;; +;; In the visualizer, the usual keys for moving up and down a buffer instead +;; move up and down the undo history tree (e.g. the up and down arrow keys, or +;; "C-n" and "C-p"). The state of the "parent" buffer (the buffer whose undo +;; history you are visualizing) is updated as you move around the undo tree in +;; the visualizer. If you reach a branch point in the visualizer, the usual +;; keys for moving forward and backward in a buffer instead switch branch +;; (e.g. the left and right arrow keys, or "C-f" and "C-b"). +;; +;; Clicking with the mouse on any node in the visualizer will take you +;; directly to that node, resetting the state of the parent buffer to the +;; state represented by that node. +;; +;; You can also select nodes directly using the keyboard, by hitting "s" to +;; toggle selection mode. The usual motion keys now allow you to move around +;; the tree without changing the parent buffer. Hitting will reset the +;; state of the parent buffer to the state represented by the currently +;; selected node. +;; +;; It can be useful to see how long ago the parent buffer was in the state +;; represented by a particular node in the visualizer. Hitting "t" in the +;; visualizer toggles the display of time-stamps for all the nodes. (Note +;; that, because of the way `undo-tree-mode' works, these time-stamps may be +;; somewhat later than the true times, especially if it's been a long time +;; since you last undid any changes.) +;; +;; To get some idea of what changes are represented by a given node in the +;; tree, it can be useful to see a diff of the changes. Hit "d" in the +;; visualizer to toggle a diff display. This normally displays a diff between +;; the current state and the previous one, i.e. it shows you the changes that +;; will be applied if you undo (move up the tree). However, the diff display +;; really comes into its own in the visualizer's selection mode (see above), +;; where it instead shows a diff between the current state and the currently +;; selected state, i.e. it shows you the changes that will be applied if you +;; reset to the selected state. +;; +;; (Note that the diff is generated by the Emacs `diff' command, and is +;; displayed using `diff-mode'. See the corresponding customization groups if +;; you want to customize the diff display.) +;; +;; Finally, hitting "q" will quit the visualizer, leaving the parent buffer in +;; whatever state you ended at. Hitting "C-q" will abort the visualizer, +;; returning the parent buffer to whatever state it was originally in when the +;; visualizer was invoked. +;; +;; +;; +;; Undo-in-Region +;; ============== +;; +;; Emacs allows a very useful and powerful method of undoing only selected +;; changes: when a region is active, only changes that affect the text within +;; that region will be undone. With the standard Emacs undo system, changes +;; produced by undoing-in-region naturally get added onto the end of the +;; linear undo history: +;; +;; o +;; | +;; | x (second undo-in-region) +;; o | +;; | | +;; | o (first undo-in-region) +;; o | +;; | / +;; |/ +;; o +;; +;; You can of course redo these undos-in-region as usual, by undoing the +;; undos: +;; +;; o +;; | +;; | o_ +;; o | \ +;; | | | +;; | o o (undo the undo-in-region) +;; o | | +;; | / | +;; |/ | +;; o x (undo the undo-in-region) +;; +;; +;; In `undo-tree-mode', undo-in-region works much the same way: when there's +;; an active region, undoing only undoes changes that affect that region. In +;; `undo-tree-mode', redoing when there's an active region similarly only +;; redoes changes that affect that region. +;; +;; However, the way these undo- and redo-in-region changes are recorded in the +;; undo history is quite different. The good news is, you don't need to +;; understand this to use undo- and redo-in-region in `undo-tree-mode' - just +;; go ahead and use them! They'll probably work as you expect. But if you're +;; masochistic enough to want to understand conceptually what's happening to +;; the undo tree as you undo- and redo-in-region, then read on... +;; +;; +;; Undo-in-region creates a new branch in the undo history. The new branch +;; consists of an undo step that undoes some of the changes that affect the +;; current region, and another step that undoes the remaining changes needed +;; to rejoin the previous undo history. +;; +;; Previous undo history Undo-in-region +;; +;; o o +;; | | +;; | | +;; | | +;; o o +;; | | +;; | | +;; | | +;; o o_ +;; | | \ +;; | | x (undo-in-region) +;; | | | +;; x o o +;; +;; As long as you don't change the active region after undoing-in-region, +;; continuing to undo-in-region extends the new branch, pulling more changes +;; that affect the current region into an undo step immediately above your +;; current location in the undo tree, and pushing the point at which the new +;; branch is attached further up the tree: +;; +;; First undo-in-region Second undo-in-region +;; +;; o o +;; | | +;; | | +;; | | +;; o o_ +;; | | \ +;; | | x (undo-in-region) +;; | | | +;; o_ o | +;; | \ | | +;; | x | o +;; | | | | +;; o o o o +;; +;; Redoing takes you back down the undo tree, as usual (as long as you haven't +;; changed the active region after undoing-in-region, it doesn't matter if it +;; is still active): +;; +;; o +;; | +;; | +;; | +;; o_ +;; | \ +;; | o +;; | | +;; o | +;; | | +;; | o (redo) +;; | | +;; o x (redo) +;; +;; +;; What about redo-in-region? Obviously, redo-in-region only makes sense if +;; you have already undone some changes, so that there are some changes to +;; redo! Redoing-in-region splits off a new branch of the undo history below +;; your current location in the undo tree. This time, the new branch consists +;; of a first redo step that redoes some of the redo changes that affect the +;; current region, followed by *all* the remaining redo changes. +;; +;; Previous undo history Redo-in-region +;; +;; o o +;; | | +;; | | +;; | | +;; x o_ +;; | | \ +;; | | x (redo-in-region) +;; | | | +;; o o | +;; | | | +;; | | | +;; | | | +;; o o o +;; +;; As long as you don't change the active region after redoing-in-region, +;; continuing to redo-in-region extends the new branch, pulling more redo +;; changes into a redo step immediately below your current location in the +;; undo tree. +;; +;; First redo-in-region Second redo-in-region +;; +;; o o +;; | | +;; | | +;; | | +;; o_ o_ +;; | \ | \ +;; | x | o +;; | | | | +;; o | o | +;; | | | | +;; | | | x (redo-in-region) +;; | | | | +;; o o o o +;; +;; Note that undo-in-region and redo-in-region only ever add new changes to +;; the undo tree, they *never* modify existing undo history. So you can always +;; return to previous buffer states by switching to a previous branch of the +;; tree. + + + +;;; Code: + +(require 'cl-lib) +(require 'queue) +(require 'diff) +(require 'gv) + + + +;;; ===================================================================== +;;; Compatibility hacks for older Emacsen + +;; `characterp' isn't defined in Emacs versions < 23 +(unless (fboundp 'characterp) + (defalias 'characterp 'char-valid-p)) + +;; `region-active-p' isn't defined in Emacs versions < 23 +(unless (fboundp 'region-active-p) + (defun region-active-p () (and transient-mark-mode mark-active))) + + +;; `registerv' defstruct isn't defined in Emacs versions < 24 +(unless (fboundp 'registerv-make) + (defmacro registerv-make (data &rest _dummy) data)) + +(unless (fboundp 'registerv-data) + (defmacro registerv-data (data) data)) + + +;; `diff-no-select' and `diff-file-local-copy' aren't defined in Emacs +;; versions < 24 (copied and adapted from Emacs 24) +(unless (fboundp 'diff-no-select) + (defun diff-no-select (old new &optional switches no-async buf) + ;; Noninteractive helper for creating and reverting diff buffers + (unless (bufferp new) (setq new (expand-file-name new))) + (unless (bufferp old) (setq old (expand-file-name old))) + (or switches (setq switches diff-switches)) ; If not specified, use default. + (unless (listp switches) (setq switches (list switches))) + (or buf (setq buf (get-buffer-create "*Diff*"))) + (let* ((old-alt (diff-file-local-copy old)) + (new-alt (diff-file-local-copy new)) + (command + (mapconcat 'identity + `(,diff-command + ;; Use explicitly specified switches + ,@switches + ,@(mapcar #'shell-quote-argument + (nconc + (when (or old-alt new-alt) + (list "-L" (if (stringp old) + old (prin1-to-string old)) + "-L" (if (stringp new) + new (prin1-to-string new)))) + (list (or old-alt old) + (or new-alt new))))) + " ")) + (thisdir default-directory)) + (with-current-buffer buf + (setq buffer-read-only t) + (buffer-disable-undo (current-buffer)) + (let ((inhibit-read-only t)) + (erase-buffer)) + (buffer-enable-undo (current-buffer)) + (diff-mode) + (set (make-local-variable 'revert-buffer-function) + (lambda (_ignore-auto _noconfirm) + (diff-no-select old new switches no-async (current-buffer)))) + (setq default-directory thisdir) + (let ((inhibit-read-only t)) + (insert command "\n")) + (if (and (not no-async) (fboundp 'start-process)) + (let ((proc (start-process "Diff" buf shell-file-name + shell-command-switch command))) + (set-process-filter proc 'diff-process-filter) + (set-process-sentinel + proc (lambda (proc _msg) + (with-current-buffer (process-buffer proc) + (diff-sentinel (process-exit-status proc)) + (if old-alt (delete-file old-alt)) + (if new-alt (delete-file new-alt)))))) + ;; Async processes aren't available. + (let ((inhibit-read-only t)) + (diff-sentinel + (call-process shell-file-name nil buf nil + shell-command-switch command)) + (if old-alt (delete-file old-alt)) + (if new-alt (delete-file new-alt))))) + buf))) + +(unless (fboundp 'diff-file-local-copy) + (defun diff-file-local-copy (file-or-buf) + (if (bufferp file-or-buf) + (with-current-buffer file-or-buf + (let ((tempfile (make-temp-file "buffer-content-"))) + (write-region nil nil tempfile nil 'nomessage) + tempfile)) + (file-local-copy file-or-buf)))) + + +;; `user-error' isn't defined in Emacs < 24.3 +(unless (fboundp 'user-error) + (defalias 'user-error 'error) + ;; prevent debugger being called on user errors + (add-to-list 'debug-ignored-errors "^No further undo information") + (add-to-list 'debug-ignored-errors "^No further redo information") + (add-to-list 'debug-ignored-errors "^No further redo information for region")) + + + + + +;;; ===================================================================== +;;; Global variables and customization options + +(defvar buffer-undo-tree nil + "Tree of undo entries in current buffer.") +(put 'buffer-undo-tree 'permanent-local t) +(make-variable-buffer-local 'buffer-undo-tree) + + +(defgroup undo-tree nil + "Tree undo/redo." + :group 'undo) + + +(defcustom undo-tree-limit 80000000 + "Value of `undo-limit' used in `undo-tree-mode'. + +If `undo-limit' is larger than `undo-tree-limit', the larger of +the two values will be used. + +See also `undo-tree-strong-limit' and `undo-tree-outer-limit'. + +Setting this to nil prevents `undo-tree-mode' ever discarding +undo history. (As far as possible. In principle, it is still +possible for Emacs to discard undo history behind +`undo-tree-mode's back.) USE THIS SETTING AT YOUR OWN RISK! Emacs +may crash if undo history exceeds Emacs' available memory. This +is particularly risky if `undo-tree-auto-save-history' is +enabled, as in that case undo history is preserved even between +Emacs sessions." + :group 'undo-tree + :type '(choice integer (const nil))) + + +(defcustom undo-tree-strong-limit 120000000 + "Value of `undo-strong-limit' used in `undo-tree-mode'. + +If `undo-strong-limit' is larger than `undo-tree-strong-limit' +the larger of the two values will be used." + :group 'undo-tree + :type 'integer) + + +(defcustom undo-tree-outer-limit 360000000 + "Value of `undo-outer-limit' used in `undo-tree-mode'. + +If `undo-outer-limit' is larger than `undo-tree-outer-limit' the +larger of the two values will be used." + :group 'undo-tree + :type 'integer) + + +(defcustom undo-tree-mode-lighter " Undo-Tree" + "Lighter displayed in mode line +when `undo-tree-mode' is enabled." + :group 'undo-tree + :type 'string) + + +(defcustom undo-tree-incompatible-major-modes '(term-mode) + "List of major-modes in which `undo-tree-mode' should not be enabled. +\(See `turn-on-undo-tree-mode'.\)" + :group 'undo-tree + :type '(repeat symbol)) + + +(defcustom undo-tree-enable-undo-in-region nil + "When non-nil, enable undo-in-region. + +When undo-in-region is enabled, undoing or redoing when the +region is active (in `transient-mark-mode') or with a prefix +argument (not in `transient-mark-mode') only undoes changes +within the current region." + :group 'undo-tree + :type 'boolean) + + +(defcustom undo-tree-auto-save-history t + "When non-nil, `undo-tree-mode' will save undo history to file +when a buffer is saved to file. + +It will automatically load undo history when a buffer is loaded +from file, if an undo save file exists. + +By default, undo-tree history is saved to a file called +\"..~undo-tree~\" in the same directory as the +file itself. To save under a different directory, customize +`undo-tree-history-directory-alist' (see the documentation for +that variable for details). + +WARNING! `undo-tree-auto-save-history' will not work properly in +Emacs versions prior to 24.3, so it cannot be enabled via +the customization interface in versions earlier than that one. To +ignore this warning and enable it regardless, set +`undo-tree-auto-save-history' to a non-nil value outside of +customize." + :group 'undo-tree + :type (if (version-list-< (version-to-list emacs-version) '(24 3)) + '(choice (const :tag "" nil)) + 'boolean)) + + +(defcustom undo-tree-history-directory-alist nil + "Alist of filename patterns and undo history directory names. +Each element looks like (REGEXP . DIRECTORY). Undo history for +files with names matching REGEXP will be saved in DIRECTORY. +DIRECTORY may be relative or absolute. If it is absolute, so +that all matching files are backed up into the same directory, +the file names in this directory will be the full name of the +file backed up with all directory separators changed to `!' to +prevent clashes. This will not work correctly if your filesystem +truncates the resulting name. + +For the common case of all backups going into one directory, the +alist should contain a single element pairing \".\" with the +appropriate directory name. + +If this variable is nil, or it fails to match a filename, the +backup is made in the original file's directory. + +On MS-DOS filesystems without long names this variable is always +ignored." + :group 'undo-tree + :type '(repeat (cons (regexp :tag "Regexp matching filename") + (directory :tag "Undo history directory name")))) + + + +(defcustom undo-tree-visualizer-relative-timestamps t + "When non-nil, display times relative to current time +when displaying time stamps in visualizer. + +Otherwise, display absolute times." + :group 'undo-tree + :type 'boolean) + + +(defcustom undo-tree-visualizer-timestamps nil + "When non-nil, display time-stamps by default +in undo-tree visualizer. + +\\You can always toggle time-stamps on and off \ +using \\[undo-tree-visualizer-toggle-timestamps], regardless of the +setting of this variable." + :group 'undo-tree + :type 'boolean) + + +(defcustom undo-tree-visualizer-diff nil + "When non-nil, display diff by default in undo-tree visualizer. + +\\You can always toggle the diff display \ +using \\[undo-tree-visualizer-toggle-diff], regardless of the +setting of this variable." + :group 'undo-tree + :type 'boolean) + + +(defcustom undo-tree-visualizer-lazy-drawing 100 + "When non-nil, use lazy undo-tree drawing in visualizer. + +Setting this to a number causes the visualizer to switch to lazy +drawing when the number of nodes in the tree is larger than this +value. + +Lazy drawing means that only the visible portion of the tree will +be drawn initially, and the tree will be extended later as +needed. For the most part, the only visible effect of this is to +significantly speed up displaying the visualizer for very large +trees. + +There is one potential negative effect of lazy drawing. Other +branches of the tree will only be drawn once the node from which +they branch off becomes visible. So it can happen that certain +portions of the tree that would be shown with lazy drawing +disabled, will not be drawn immediately when it is +enabled. However, this effect is quite rare in practice." + :group 'undo-tree + :type '(choice (const :tag "never" nil) + (const :tag "always" t) + (integer :tag "> size"))) + + +(defvar undo-tree-pre-save-element-functions '() + "Special hook to modify undo-tree elements prior to saving. +Each function on this hook is called in turn on each undo element +in the tree by `undo-tree-save-history' prior to writing the undo +history to file. It should return either nil, which removes that +undo element from the saved history, or a replacement element to +use instead (which should be identical to the original element if +that element should be saved unchanged).") + + +(defvar undo-tree-post-load-element-functions '() + "Special hook to modify undo-tree undo elements after loading. +Each function on this hook is called in turn on each undo element +in the tree by `undo-tree-load-history' after loading the undo +history from file. It should return either nil, which removes that +undo element from the loaded history, or a replacement element to +use instead (which should be identical to the original element if +that element should be loaded unchanged).") + + +(defface undo-tree-visualizer-default-face + '((((class color)) :foreground "gray")) + "Face used to draw undo-tree in visualizer." + :group 'undo-tree) + +(defface undo-tree-visualizer-current-face + '((((class color)) :foreground "red")) + "Face used to highlight current undo-tree node in visualizer." + :group 'undo-tree) + +(defface undo-tree-visualizer-active-branch-face + '((((class color) (background dark)) + (:foreground "white" :weight bold)) + (((class color) (background light)) + (:foreground "black" :weight bold))) + "Face used to highlight active undo-tree branch in visualizer." + :group 'undo-tree) + +(defface undo-tree-visualizer-register-face + '((((class color)) :foreground "yellow")) + "Face used to highlight undo-tree nodes saved to a register +in visualizer." + :group 'undo-tree) + +(defface undo-tree-visualizer-unmodified-face + '((((class color)) :foreground "cyan")) + "Face used to highlight nodes corresponding to unmodified buffers +in visualizer." + :group 'undo-tree) + + +(defvar undo-tree-visualizer-parent-buffer nil + "Parent buffer in visualizer.") +(put 'undo-tree-visualizer-parent-buffer 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-parent-buffer) + +;; stores modification time of parent buffer's file, if any +(defvar undo-tree-visualizer-parent-mtime nil) +(put 'undo-tree-visualizer-parent-mtime 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-parent-mtime) + +;; stores current horizontal spacing needed for drawing undo-tree +(defvar undo-tree-visualizer-spacing nil) +(put 'undo-tree-visualizer-spacing 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-spacing) + +;; calculate horizontal spacing required for drawing tree with current +;; settings +(defsubst undo-tree-visualizer-calculate-spacing () + (if undo-tree-visualizer-timestamps + (if undo-tree-visualizer-relative-timestamps 9 13) + 3)) + +;; holds node that was current when visualizer was invoked +(defvar undo-tree-visualizer-initial-node nil) +(put 'undo-tree-visualizer-initial-node 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-initial-node) + +;; holds currently selected node in visualizer selection mode +(defvar undo-tree-visualizer-selected-node nil) +(put 'undo-tree-visualizer-selected-node 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-selected) + +;; used to store nodes at edge of currently drawn portion of tree +(defvar undo-tree-visualizer-needs-extending-down nil) +(put 'undo-tree-visualizer-needs-extending-down 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-needs-extending-down) +(defvar undo-tree-visualizer-needs-extending-up nil) +(put 'undo-tree-visualizer-needs-extending-up 'permanent-local t) +(make-variable-buffer-local 'undo-tree-visualizer-needs-extending-up) + +;; dynamically bound to t when undoing from visualizer, to inhibit +;; `undo-tree-kill-visualizer' hook function in parent buffer +(defvar undo-tree-inhibit-kill-visualizer nil) + +;; can be let-bound to a face name, used in drawing functions +(defvar undo-tree-insert-face nil) + +;; visualizer buffer names +(defconst undo-tree-visualizer-buffer-name " *undo-tree*") +(defconst undo-tree-diff-buffer-name "*undo-tree Diff*") + + + + +;;; ================================================================= +;;; Default keymaps + +(defvar undo-tree-map nil + "Keymap used in undo-tree-mode.") + +(unless undo-tree-map + (let ((map (make-sparse-keymap))) + ;; remap `undo' and `undo-only' to `undo-tree-undo' + (define-key map [remap undo] 'undo-tree-undo) + (define-key map [remap undo-only] 'undo-tree-undo) + ;; bind standard undo bindings (since these match redo counterparts) + (define-key map (kbd "C-/") 'undo-tree-undo) + (define-key map "\C-_" 'undo-tree-undo) + ;; redo doesn't exist normally, so define our own keybindings + (define-key map (kbd "C-?") 'undo-tree-redo) + (define-key map (kbd "M-_") 'undo-tree-redo) + ;; just in case something has defined `redo'... + (define-key map [remap redo] 'undo-tree-redo) + ;; we use "C-x u" for the undo-tree visualizer + (define-key map (kbd "\C-x u") 'undo-tree-visualize) + ;; bind register commands + (define-key map (kbd "C-x r u") 'undo-tree-save-state-to-register) + (define-key map (kbd "C-x r U") 'undo-tree-restore-state-from-register) + ;; set keymap + (setq undo-tree-map map))) + + +(defvar undo-tree-visualizer-mode-map nil + "Keymap used in undo-tree visualizer.") + +(unless undo-tree-visualizer-mode-map + (let ((map (make-sparse-keymap))) + ;; vertical motion keys undo/redo + (define-key map [remap previous-line] 'undo-tree-visualize-undo) + (define-key map [remap next-line] 'undo-tree-visualize-redo) + (define-key map [up] 'undo-tree-visualize-undo) + (define-key map "p" 'undo-tree-visualize-undo) + (define-key map "\C-p" 'undo-tree-visualize-undo) + (define-key map [down] 'undo-tree-visualize-redo) + (define-key map "n" 'undo-tree-visualize-redo) + (define-key map "\C-n" 'undo-tree-visualize-redo) + ;; horizontal motion keys switch branch + (define-key map [remap forward-char] + 'undo-tree-visualize-switch-branch-right) + (define-key map [remap backward-char] + 'undo-tree-visualize-switch-branch-left) + (define-key map [right] 'undo-tree-visualize-switch-branch-right) + (define-key map "f" 'undo-tree-visualize-switch-branch-right) + (define-key map "\C-f" 'undo-tree-visualize-switch-branch-right) + (define-key map [left] 'undo-tree-visualize-switch-branch-left) + (define-key map "b" 'undo-tree-visualize-switch-branch-left) + (define-key map "\C-b" 'undo-tree-visualize-switch-branch-left) + ;; paragraph motion keys undo/redo to significant points in tree + (define-key map [remap backward-paragraph] 'undo-tree-visualize-undo-to-x) + (define-key map [remap forward-paragraph] 'undo-tree-visualize-redo-to-x) + (define-key map "\M-{" 'undo-tree-visualize-undo-to-x) + (define-key map "\M-}" 'undo-tree-visualize-redo-to-x) + (define-key map [C-up] 'undo-tree-visualize-undo-to-x) + (define-key map [C-down] 'undo-tree-visualize-redo-to-x) + ;; mouse sets buffer state to node at click + (define-key map [mouse-1] 'undo-tree-visualizer-mouse-set) + ;; toggle timestamps + (define-key map "t" 'undo-tree-visualizer-toggle-timestamps) + ;; toggle diff + (define-key map "d" 'undo-tree-visualizer-toggle-diff) + ;; toggle selection mode + (define-key map "s" 'undo-tree-visualizer-selection-mode) + ;; horizontal scrolling may be needed if the tree is very wide + (define-key map "," 'undo-tree-visualizer-scroll-left) + (define-key map "." 'undo-tree-visualizer-scroll-right) + (define-key map "<" 'undo-tree-visualizer-scroll-left) + (define-key map ">" 'undo-tree-visualizer-scroll-right) + ;; vertical scrolling may be needed if the tree is very tall + (define-key map [next] 'undo-tree-visualizer-scroll-up) + (define-key map [prior] 'undo-tree-visualizer-scroll-down) + ;; quit/abort visualizer + (define-key map "q" 'undo-tree-visualizer-quit) + (define-key map "\C-q" 'undo-tree-visualizer-abort) + ;; set keymap + (setq undo-tree-visualizer-mode-map map))) + + +(defvar undo-tree-visualizer-selection-mode-map nil + "Keymap used in undo-tree visualizer selection mode.") + +(unless undo-tree-visualizer-selection-mode-map + (let ((map (make-sparse-keymap))) + ;; vertical motion keys move up and down tree + (define-key map [remap previous-line] + 'undo-tree-visualizer-select-previous) + (define-key map [remap next-line] + 'undo-tree-visualizer-select-next) + (define-key map [up] 'undo-tree-visualizer-select-previous) + (define-key map "p" 'undo-tree-visualizer-select-previous) + (define-key map "\C-p" 'undo-tree-visualizer-select-previous) + (define-key map [down] 'undo-tree-visualizer-select-next) + (define-key map "n" 'undo-tree-visualizer-select-next) + (define-key map "\C-n" 'undo-tree-visualizer-select-next) + ;; vertical scroll keys move up and down quickly + (define-key map [next] + (lambda () (interactive) (undo-tree-visualizer-select-next 10))) + (define-key map [prior] + (lambda () (interactive) (undo-tree-visualizer-select-previous 10))) + ;; horizontal motion keys move to left and right siblings + (define-key map [remap forward-char] 'undo-tree-visualizer-select-right) + (define-key map [remap backward-char] 'undo-tree-visualizer-select-left) + (define-key map [right] 'undo-tree-visualizer-select-right) + (define-key map "f" 'undo-tree-visualizer-select-right) + (define-key map "\C-f" 'undo-tree-visualizer-select-right) + (define-key map [left] 'undo-tree-visualizer-select-left) + (define-key map "b" 'undo-tree-visualizer-select-left) + (define-key map "\C-b" 'undo-tree-visualizer-select-left) + ;; horizontal scroll keys move left or right quickly + (define-key map "," + (lambda () (interactive) (undo-tree-visualizer-select-left 10))) + (define-key map "." + (lambda () (interactive) (undo-tree-visualizer-select-right 10))) + (define-key map "<" + (lambda () (interactive) (undo-tree-visualizer-select-left 10))) + (define-key map ">" + (lambda () (interactive) (undo-tree-visualizer-select-right 10))) + ;; sets buffer state to node at point + (define-key map "\r" 'undo-tree-visualizer-set) + ;; mouse selects node at click + (define-key map [mouse-1] 'undo-tree-visualizer-mouse-select) + ;; toggle diff + (define-key map "d" 'undo-tree-visualizer-selection-toggle-diff) + ;; set keymap + (setq undo-tree-visualizer-selection-mode-map map))) + + + + +;;; ===================================================================== +;;; Undo-tree data structure + +(cl-defstruct + (undo-tree + :named + (:constructor nil) + (:constructor make-undo-tree + (&aux + (root (undo-tree-make-node nil nil)) + (current root) + (size 0) + (count 0) + (object-pool (make-hash-table :test 'eq :weakness 'value)))) + (:copier nil)) + root current size count object-pool) + +(defun undo-tree-copy (tree) + ;; Return a copy of undo-tree TREE. + (unwind-protect + (let ((new (make-undo-tree))) + (undo-tree-decircle tree) + (let ((max-lisp-eval-depth (* 100 (undo-tree-count tree))) + (max-specpdl-size (* 100 (undo-tree-count tree)))) + (setf (undo-tree-root new) + (undo-tree-node-copy (undo-tree-root tree) + new (undo-tree-current tree)))) + (setf (undo-tree-size new) + (undo-tree-size tree)) + (setf (undo-tree-count new) + (undo-tree-count tree)) + (setf (undo-tree-object-pool new) + (copy-hash-table (undo-tree-object-pool tree))) + (undo-tree-recircle new) + new) + (undo-tree-recircle tree))) + + +(cl-defstruct + (undo-tree-node + (:type vector) ; create unnamed struct + (:constructor nil) + (:constructor undo-tree-make-node + (previous undo + &optional redo + &aux + (timestamp (current-time)) + (branch 0))) + (:constructor undo-tree-make-node-backwards + (next-node undo + &optional redo + &aux + (next (list next-node)) + (timestamp (current-time)) + (branch 0))) + (:constructor undo-tree-make-empty-node ()) + (:constructor undo-tree-copy-node-save-data + (node + &aux + (undo (let ((changeset (undo-tree-node-undo node))) + (run-hook-wrapped + 'undo-tree-pre-save-element-functions + (lambda (fun) + (setq changeset (delq nil (mapcar fun changeset))) + nil)) + changeset)) + (redo (let ((changeset (undo-tree-node-redo node))) + (run-hook-wrapped + 'undo-tree-pre-save-element-functions + (lambda (fun) + (setq changeset (delq nil (mapcar fun changeset))) + nil)) + changeset)) + (timestamp (undo-tree-node-timestamp node)) + (branch (undo-tree-node-branch node)) + (meta-data (undo-tree-node-meta-data node)))) + (:copier nil)) + previous next undo redo timestamp branch meta-data) + + +(defmacro undo-tree-node-p (n) + (let ((len (length (undo-tree-make-node nil nil)))) + `(and (vectorp ,n) (= (length ,n) ,len)))) + +(defun undo-tree-node-copy (node &optional tree current) + ;; Return a deep copy of undo-tree NODE, sans previous link or meta-data. + ;; If TREE and CURRENT are supplied, set (undo-tree-current TREE) to the + ;; copy of CURRENT node, if found. + (let* ((new (undo-tree-make-empty-node)) + (stack (list (cons node new))) + n) + (while (setq n (pop stack)) + (setf (undo-tree-node-undo (cdr n)) + (copy-tree (undo-tree-node-undo (car n)) 'copy-vectors)) + (setf (undo-tree-node-redo (cdr n)) + (copy-tree (undo-tree-node-redo (car n)) 'copy-vectors)) + (setf (undo-tree-node-timestamp (cdr n)) + (copy-sequence (undo-tree-node-timestamp (car n)))) + (setf (undo-tree-node-branch (cdr n)) + (undo-tree-node-branch (car n))) + (setf (undo-tree-node-next (cdr n)) + (mapcar (lambda (_) (undo-tree-make-empty-node)) + (make-list (length (undo-tree-node-next (car n))) nil))) + ;; set (undo-tree-current TREE) to copy if we've found CURRENT + (when (and tree (eq (car n) current)) + (setf (undo-tree-current tree) (cdr n))) + ;; recursively copy next nodes + (let ((next0 (undo-tree-node-next (car n))) + (next1 (undo-tree-node-next (cdr n)))) + (while (and next0 next1) + (push (cons (pop next0) (pop next1)) stack)))) + new)) + + +(cl-defstruct + (undo-tree-region-data + (:type vector) ; create unnamed struct + (:constructor nil) + (:constructor undo-tree-make-region-data + (&optional undo-beginning undo-end + redo-beginning redo-end)) + (:constructor undo-tree-make-undo-region-data + (undo-beginning undo-end)) + (:constructor undo-tree-make-redo-region-data + (redo-beginning redo-end)) + (:copier nil)) + undo-beginning undo-end redo-beginning redo-end) + + +(defmacro undo-tree-region-data-p (r) + (let ((len (length (undo-tree-make-region-data)))) + `(and (vectorp ,r) (= (length ,r) ,len)))) + +(defmacro undo-tree-node-clear-region-data (node) + `(setf (undo-tree-node-meta-data ,node) + (delq nil + (delq :region + (plist-put (undo-tree-node-meta-data ,node) + :region nil))))) + + +(defmacro undo-tree-node-undo-beginning (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-undo-beginning r)))) + +(defmacro undo-tree-node-undo-end (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-undo-end r)))) + +(defmacro undo-tree-node-redo-beginning (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-redo-beginning r)))) + +(defmacro undo-tree-node-redo-end (node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (when (undo-tree-region-data-p r) + (undo-tree-region-data-redo-end r)))) + + +(gv-define-setter undo-tree-node-undo-beginning (val node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (undo-tree-make-region-data))))) + (setf (undo-tree-region-data-undo-beginning r) ,val))) + +(gv-define-setter undo-tree-node-undo-end (val node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (undo-tree-make-region-data))))) + (setf (undo-tree-region-data-undo-end r) ,val))) + +(gv-define-setter undo-tree-node-redo-beginning (val node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (undo-tree-make-region-data))))) + (setf (undo-tree-region-data-redo-beginning r) ,val))) + +(gv-define-setter undo-tree-node-redo-end (val node) + `(let ((r (plist-get (undo-tree-node-meta-data ,node) :region))) + (unless (undo-tree-region-data-p r) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :region + (setq r (undo-tree-make-region-data))))) + (setf (undo-tree-region-data-redo-end r) ,val))) + + + +(cl-defstruct + (undo-tree-visualizer-data + (:type vector) ; create unnamed struct + (:constructor nil) + (:constructor undo-tree-make-visualizer-data + (&optional lwidth cwidth rwidth marker)) + (:copier nil)) + lwidth cwidth rwidth marker) + + +(defmacro undo-tree-visualizer-data-p (v) + (let ((len (length (undo-tree-make-visualizer-data)))) + `(and (vectorp ,v) (= (length ,v) ,len)))) + +(defun undo-tree-node-clear-visualizer-data (node) + (let ((plist (undo-tree-node-meta-data node))) + (if (eq (car plist) :visualizer) + (setf (undo-tree-node-meta-data node) (nthcdr 2 plist)) + (while (and plist (not (eq (cadr plist) :visualizer))) + (setq plist (cdr plist))) + (if plist (setcdr plist (nthcdr 3 plist)))))) + +(defmacro undo-tree-node-lwidth (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-lwidth v)))) + +(defmacro undo-tree-node-cwidth (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-cwidth v)))) + +(defmacro undo-tree-node-rwidth (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-rwidth v)))) + +(defmacro undo-tree-node-marker (node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (when (undo-tree-visualizer-data-p v) + (undo-tree-visualizer-data-marker v)))) + + +(gv-define-setter undo-tree-node-lwidth (val node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (undo-tree-make-visualizer-data))))) + (setf (undo-tree-visualizer-data-lwidth v) ,val))) + +(gv-define-setter undo-tree-node-cwidth (val node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (undo-tree-make-visualizer-data))))) + (setf (undo-tree-visualizer-data-cwidth v) ,val))) + +(gv-define-setter undo-tree-node-rwidth (val node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (undo-tree-make-visualizer-data))))) + (setf (undo-tree-visualizer-data-rwidth v) ,val))) + +(gv-define-setter undo-tree-node-marker (val node) + `(let ((v (plist-get (undo-tree-node-meta-data ,node) :visualizer))) + (unless (undo-tree-visualizer-data-p v) + (setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :visualizer + (setq v (undo-tree-make-visualizer-data))))) + (setf (undo-tree-visualizer-data-marker v) ,val))) + + + +(cl-defstruct + (undo-tree-register-data + (:type vector) + (:constructor nil) + (:constructor undo-tree-make-register-data (buffer node))) + buffer node) + +(defun undo-tree-register-data-p (data) + (and (vectorp data) + (= (length data) 2) + (undo-tree-node-p (undo-tree-register-data-node data)))) + +(defun undo-tree-register-data-print-func (data) + (princ (format "an undo-tree state for buffer %s" + (undo-tree-register-data-buffer data)))) + +(defmacro undo-tree-node-register (node) + `(plist-get (undo-tree-node-meta-data ,node) :register)) + +(gv-define-setter undo-tree-node-register (val node) + `(setf (undo-tree-node-meta-data ,node) + (plist-put (undo-tree-node-meta-data ,node) :register ,val))) + + + + +;;; ===================================================================== +;;; Basic undo-tree data structure functions + +(defun undo-tree-grow (undo) + "Add an UNDO node to current branch of `buffer-undo-tree'." + (let* ((current (undo-tree-current buffer-undo-tree)) + (new (undo-tree-make-node current undo))) + (push new (undo-tree-node-next current)) + (setf (undo-tree-current buffer-undo-tree) new))) + + +(defun undo-tree-grow-backwards (node undo &optional redo) + "Add new node *above* undo-tree NODE, and return new node. +Note that this will overwrite NODE's \"previous\" link, so should +only be used on a detached NODE, never on nodes that are already +part of `buffer-undo-tree'." + (let ((new (undo-tree-make-node-backwards node undo redo))) + (setf (undo-tree-node-previous node) new) + new)) + + +(defun undo-tree-splice-node (node splice) + "Splice NODE into undo tree, below node SPLICE. +Note that this will overwrite NODE's \"next\" and \"previous\" +links, so should only be used on a detached NODE, never on nodes +that are already part of `buffer-undo-tree'." + (setf (undo-tree-node-next node) (undo-tree-node-next splice) + (undo-tree-node-branch node) (undo-tree-node-branch splice) + (undo-tree-node-previous node) splice + (undo-tree-node-next splice) (list node) + (undo-tree-node-branch splice) 0) + (dolist (n (undo-tree-node-next node)) + (setf (undo-tree-node-previous n) node))) + + +(defun undo-tree-snip-node (node) + "Snip NODE out of undo tree." + (let* ((parent (undo-tree-node-previous node)) + position p) + ;; if NODE is only child, replace parent's next links with NODE's + (if (= (length (undo-tree-node-next parent)) 0) + (setf (undo-tree-node-next parent) (undo-tree-node-next node) + (undo-tree-node-branch parent) (undo-tree-node-branch node)) + ;; otherwise... + (setq position (undo-tree-position node (undo-tree-node-next parent))) + (cond + ;; if active branch used do go via NODE, set parent's branch to active + ;; branch of NODE + ((= (undo-tree-node-branch parent) position) + (setf (undo-tree-node-branch parent) + (+ position (undo-tree-node-branch node)))) + ;; if active branch didn't go via NODE, update parent's branch to point + ;; to same node as before + ((> (undo-tree-node-branch parent) position) + (cl-incf (undo-tree-node-branch parent) + (1- (length (undo-tree-node-next node)))))) + ;; replace NODE in parent's next list with NODE's entire next list + (if (= position 0) + (setf (undo-tree-node-next parent) + (nconc (undo-tree-node-next node) + (cdr (undo-tree-node-next parent)))) + (setq p (nthcdr (1- position) (undo-tree-node-next parent))) + (setcdr p (nconc (undo-tree-node-next node) (cddr p))))) + ;; update previous links of NODE's children + (dolist (n (undo-tree-node-next node)) + (setf (undo-tree-node-previous n) parent)))) + + +(defun undo-tree-mapc (--undo-tree-mapc-function-- node) + ;; Apply FUNCTION to NODE and to each node below it. + (let ((stack (list node)) + n) + (while (setq n (pop stack)) + (funcall --undo-tree-mapc-function-- n) + (setq stack (append (undo-tree-node-next n) stack))))) + + +(defmacro undo-tree-num-branches () + "Return number of branches at current undo tree node." + '(length (undo-tree-node-next (undo-tree-current buffer-undo-tree)))) + + +(defun undo-tree-position (node list) + "Find the first occurrence of NODE in LIST. +Return the index of the matching item, or nil of not found. +Comparison is done with `eq'." + (let ((i 0)) + (catch 'found + (while (progn + (when (eq node (car list)) (throw 'found i)) + (cl-incf i) + (setq list (cdr list)))) + nil))) + + +(defvar *undo-tree-id-counter* 0) +(make-variable-buffer-local '*undo-tree-id-counter*) + +(defmacro undo-tree-generate-id () + ;; Generate a new, unique id (uninterned symbol). + ;; The name is made by appending a number to "undo-tree-id". + ;; (Copied from CL package `gensym'.) + `(let ((num (prog1 *undo-tree-id-counter* + (cl-incf *undo-tree-id-counter*)))) + (make-symbol (format "undo-tree-id%d" num)))) + + +(defun undo-tree-decircle (undo-tree) + ;; Nullify PREVIOUS links of UNDO-TREE nodes, to make UNDO-TREE data + ;; structure non-circular. + (undo-tree-mapc + (lambda (node) + (dolist (n (undo-tree-node-next node)) + (setf (undo-tree-node-previous n) nil))) + (undo-tree-root undo-tree))) + + +(defun undo-tree-recircle (undo-tree) + ;; Recreate PREVIOUS links of UNDO-TREE nodes, to restore circular UNDO-TREE + ;; data structure. + (undo-tree-mapc + (lambda (node) + (dolist (n (undo-tree-node-next node)) + (setf (undo-tree-node-previous n) node))) + (undo-tree-root undo-tree))) + + + + +;;; ===================================================================== +;;; Undo list and undo changeset utility functions + +(defmacro undo-list-marker-elt-p (elt) + `(markerp (car-safe ,elt))) + +(defmacro undo-list-GCd-marker-elt-p (elt) + ;; Return t if ELT is a marker element whose marker has been moved to the + ;; object-pool, so may potentially have been garbage-collected. + ;; Note: Valid marker undo elements should be uniquely identified as cons + ;; cells with a symbol in the car (replacing the marker), and a number in + ;; the cdr. However, to guard against future changes to undo element + ;; formats, we perform an additional redundant check on the symbol name. + `(and (car-safe ,elt) + (symbolp (car ,elt)) + (let ((str (symbol-name (car ,elt)))) + (and (> (length str) 12) + (string= (substring str 0 12) "undo-tree-id"))) + (numberp (cdr-safe ,elt)))) + + +(defun undo-tree-move-GC-elts-to-pool (elt) + ;; Move elements that can be garbage-collected into `buffer-undo-tree' + ;; object pool, substituting a unique id that can be used to retrieve them + ;; later. (Only markers require this treatment currently.) + (when (undo-list-marker-elt-p elt) + (let ((id (undo-tree-generate-id))) + (puthash id (car elt) (undo-tree-object-pool buffer-undo-tree)) + (setcar elt id)))) + + +(defun undo-tree-restore-GC-elts-from-pool (elt) + ;; Replace object id's in ELT with corresponding objects from + ;; `buffer-undo-tree' object pool and return modified ELT, or return nil if + ;; any object in ELT has been garbage-collected. + (if (undo-list-GCd-marker-elt-p elt) + (when (setcar elt (gethash (car elt) + (undo-tree-object-pool buffer-undo-tree))) + elt) + elt)) + + +(defun undo-list-clean-GCd-elts (undo-list) + ;; Remove object id's from UNDO-LIST that refer to elements that have been + ;; garbage-collected. UNDO-LIST is modified by side-effect. + (while (undo-list-GCd-marker-elt-p (car undo-list)) + (unless (gethash (caar undo-list) + (undo-tree-object-pool buffer-undo-tree)) + (setq undo-list (cdr undo-list)))) + (let ((p undo-list)) + (while (cdr p) + (when (and (undo-list-GCd-marker-elt-p (cadr p)) + (null (gethash (car (cadr p)) + (undo-tree-object-pool buffer-undo-tree)))) + (setcdr p (cddr p))) + (setq p (cdr p)))) + undo-list) + + +(defun undo-list-found-canary-p (undo-list) + (or (eq (car undo-list) 'undo-tree-canary) + (and (null (car undo-list)) + (eq (cadr undo-list) 'undo-tree-canary)))) + + +(defmacro undo-list-pop-changeset (undo-list &optional discard-pos) + ;; Pop changeset from `undo-list'. If DISCARD-POS is non-nil, discard + ;; any position entries from changeset. + `(when (and ,undo-list (not (undo-list-found-canary-p ,undo-list))) + (let (changeset) + ;; discard initial undo boundary(ies) + (while (null (car ,undo-list)) (setq ,undo-list (cdr ,undo-list))) + ;; pop elements up to next undo boundary, discarding position entries + ;; if DISCARD-POS is non-nil + (while (null changeset) + (while (and ,undo-list (car ,undo-list) + (not (undo-list-found-canary-p ,undo-list))) + (if (and ,discard-pos (integerp (car ,undo-list))) + (setq ,undo-list (cdr ,undo-list)) + (push (pop ,undo-list) changeset) + (undo-tree-move-GC-elts-to-pool (car changeset))))) + (nreverse changeset)))) + + +(defun undo-tree-copy-list (undo-list) + ;; Return a deep copy of first changeset in `undo-list'. Object id's are + ;; replaced by corresponding objects from `buffer-undo-tree' object-pool. + (let (copy p) + ;; if first element contains an object id, replace it with object from + ;; pool, discarding element entirely if it's been GC'd + (while (and undo-list (null copy)) + (setq copy + (undo-tree-restore-GC-elts-from-pool (pop undo-list)))) + (when copy + (setq copy (list copy) + p copy) + ;; copy remaining elements, replacing object id's with objects from + ;; pool, or discarding them entirely if they've been GC'd + (while undo-list + (when (setcdr p (undo-tree-restore-GC-elts-from-pool + (undo-copy-list-1 (pop undo-list)))) + (setcdr p (list (cdr p))) + (setq p (cdr p)))) + copy))) + + +(defvar undo-tree-gc-flag nil) + +(defun undo-tree-post-gc () + (setq undo-tree-gc-flag t)) + + +(defun undo-list-transfer-to-tree () + ;; Transfer entries accumulated in `undo-list' to `buffer-undo-tree'. + + ;; `undo-list-transfer-to-tree' should never be called when undo is disabled + ;; (i.e. `buffer-undo-tree' is t) + (cl-assert (not (eq buffer-undo-tree t))) + + ;; if `buffer-undo-tree' is empty, create initial undo-tree + (when (null buffer-undo-tree) (setq buffer-undo-tree (make-undo-tree))) + + ;; garbage-collect then repeatedly try to deep-copy `buffer-undo-list' until + ;; we succeed without GC running, in an attempt to mitigate race conditions + ;; with garbage collector corrupting undo history (is this even a thing?!) + (unless (or (null buffer-undo-list) + (undo-list-found-canary-p buffer-undo-list)) + (garbage-collect)) + (let (undo-list changeset) + (setq undo-tree-gc-flag t) + (while undo-tree-gc-flag + (setq undo-tree-gc-flag nil + undo-list (copy-tree buffer-undo-list))) + (setq buffer-undo-list (list nil 'undo-tree-canary)) + + ;; create new node from first changeset in `undo-list', save old + ;; `buffer-undo-tree' current node, and make new node the current node + (when (setq changeset (undo-list-pop-changeset undo-list)) + (let* ((node (undo-tree-make-node nil changeset)) + (splice (undo-tree-current buffer-undo-tree)) + (size (undo-list-byte-size (undo-tree-node-undo node))) + (count 1)) + (setf (undo-tree-current buffer-undo-tree) node) + ;; grow tree fragment backwards using `undo-list' changesets + (while (setq changeset (undo-list-pop-changeset undo-list)) + (setq node (undo-tree-grow-backwards node changeset)) + (cl-incf size (undo-list-byte-size (undo-tree-node-undo node))) + (cl-incf count)) + + ;; if no undo history has been discarded from `undo-list' since last + ;; transfer, splice new tree fragment onto end of old + ;; `buffer-undo-tree' current node + (if (undo-list-found-canary-p undo-list) + (progn + (setf (undo-tree-node-previous node) splice) + (push node (undo-tree-node-next splice)) + (setf (undo-tree-node-branch splice) 0) + (cl-incf (undo-tree-size buffer-undo-tree) size) + (cl-incf (undo-tree-count buffer-undo-tree) count)) + + ;; if undo history has been discarded, replace entire + ;; `buffer-undo-tree' with new tree fragment + (unless (= (undo-tree-size buffer-undo-tree) 0) + (message "Undo history discarded by Emacs (see `undo-limit') - rebuilding undo-tree")) + (setq node (undo-tree-grow-backwards node nil)) + (setf (undo-tree-root buffer-undo-tree) node) + (setf (undo-tree-size buffer-undo-tree) size) + (setf (undo-tree-count buffer-undo-tree) count))))) + + ;; discard undo history if necessary + (undo-tree-discard-history)) + + +(defun undo-list-byte-size (undo-list) + ;; Return size (in bytes) of UNDO-LIST + (let ((size 0)) + (dolist (elt undo-list) + (cl-incf size 8) ; cons cells use up 8 bytes + (when (stringp (car-safe elt)) + (cl-incf size (string-bytes (car elt))))) + size)) + + + +(defun undo-list-rebuild-from-tree () + "Rebuild `buffer-undo-list' from information in `buffer-undo-tree'." + (unless (eq buffer-undo-list t) + (undo-list-transfer-to-tree) + (setq buffer-undo-list nil) + (when buffer-undo-tree + (let ((stack (list (list (undo-tree-root buffer-undo-tree))))) + (push (sort (mapcar 'identity (undo-tree-node-next (caar stack))) + (lambda (a b) + (time-less-p (undo-tree-node-timestamp a) + (undo-tree-node-timestamp b)))) + stack) + ;; Traverse tree in depth-and-oldest-first order, but add undo records + ;; on the way down, and redo records on the way up. + (while (or (car stack) + (not (eq (car (nth 1 stack)) + (undo-tree-current buffer-undo-tree)))) + (if (car stack) + (progn + (setq buffer-undo-list + (append (undo-tree-node-undo (caar stack)) + buffer-undo-list)) + (undo-boundary) + (push (sort (mapcar 'identity + (undo-tree-node-next (caar stack))) + (lambda (a b) + (time-less-p (undo-tree-node-timestamp a) + (undo-tree-node-timestamp b)))) + stack)) + (pop stack) + (setq buffer-undo-list + (append (undo-tree-node-redo (caar stack)) + buffer-undo-list)) + (undo-boundary) + (pop (car stack)))))))) + + + + +;;; ===================================================================== +;;; History discarding utility functions + +(defun undo-tree-oldest-leaf (node) + ;; Return oldest leaf node below NODE. + (while (undo-tree-node-next node) + (setq node + (car (sort (mapcar 'identity (undo-tree-node-next node)) + (lambda (a b) + (time-less-p (undo-tree-node-timestamp a) + (undo-tree-node-timestamp b))))))) + node) + + +(defun undo-tree-discard-node (node) + ;; Discard NODE from `buffer-undo-tree', and return next in line for + ;; discarding. + + ;; don't discard current node + (unless (eq node (undo-tree-current buffer-undo-tree)) + + ;; discarding root node... + (if (eq node (undo-tree-root buffer-undo-tree)) + (cond + ;; should always discard branches before root + ((> (length (undo-tree-node-next node)) 1) + (error "Trying to discard undo-tree root which still\ + has multiple branches")) + ;; don't discard root if current node is only child + ((eq (car (undo-tree-node-next node)) + (undo-tree-current buffer-undo-tree)) + nil) + ;; discard root + (t + ;; clear any register referring to root + (let ((r (undo-tree-node-register node))) + (when (and r (eq (get-register r) node)) + (set-register r nil))) + ;; make child of root into new root + (setq node (setf (undo-tree-root buffer-undo-tree) + (car (undo-tree-node-next node)))) + ;; update undo-tree size + (cl-decf (undo-tree-size buffer-undo-tree) + (+ (undo-list-byte-size (undo-tree-node-undo node)) + (undo-list-byte-size (undo-tree-node-redo node)))) + (cl-decf (undo-tree-count buffer-undo-tree)) + ;; discard new root's undo data and PREVIOUS link + (setf (undo-tree-node-undo node) nil + (undo-tree-node-redo node) nil + (undo-tree-node-previous node) nil) + ;; if new root has branches, or new root is current node, next node + ;; to discard is oldest leaf, otherwise it's new root + (if (or (> (length (undo-tree-node-next node)) 1) + (eq (car (undo-tree-node-next node)) + (undo-tree-current buffer-undo-tree))) + (undo-tree-oldest-leaf node) + node))) + + ;; discarding leaf node... + (let* ((parent (undo-tree-node-previous node)) + (current (nth (undo-tree-node-branch parent) + (undo-tree-node-next parent)))) + ;; clear any register referring to the discarded node + (let ((r (undo-tree-node-register node))) + (when (and r (eq (get-register r) node)) + (set-register r nil))) + ;; update undo-tree size + (cl-decf (undo-tree-size buffer-undo-tree) + (+ (undo-list-byte-size (undo-tree-node-undo node)) + (undo-list-byte-size (undo-tree-node-redo node)))) + (cl-decf (undo-tree-count buffer-undo-tree)) + ;; discard leaf + (setf (undo-tree-node-next parent) + (delq node (undo-tree-node-next parent)) + (undo-tree-node-branch parent) + (undo-tree-position current (undo-tree-node-next parent))) + ;; if parent has branches, or parent is current node, next node to + ;; discard is oldest leaf, otherwise it's the parent itself + (if (or (eq parent (undo-tree-current buffer-undo-tree)) + (and (undo-tree-node-next parent) + (or (not (eq parent (undo-tree-root buffer-undo-tree))) + (> (length (undo-tree-node-next parent)) 1)))) + (undo-tree-oldest-leaf parent) + parent))))) + + + +(defun undo-tree-discard-history () + "Discard undo history until we're within memory usage limits +set by `undo-limit', `undo-strong-limit' and `undo-outer-limit'." + + (when (> (undo-tree-size buffer-undo-tree) undo-limit) + ;; if there are no branches off root, first node to discard is root; + ;; otherwise it's leaf node at botom of oldest branch + (let ((node (if (> (length (undo-tree-node-next + (undo-tree-root buffer-undo-tree))) 1) + (undo-tree-oldest-leaf (undo-tree-root buffer-undo-tree)) + (undo-tree-root buffer-undo-tree))) + discarded) + + ;; discard nodes until memory use is within `undo-strong-limit' + (while (and node + (> (undo-tree-size buffer-undo-tree) undo-strong-limit)) + (setq node (undo-tree-discard-node node) + discarded t)) + + ;; discard nodes until next node to discard would bring memory use + ;; within `undo-limit' + (while (and node + ;; check first if last discard has brought us within + ;; `undo-limit', in case we can avoid more expensive + ;; `undo-strong-limit' calculation + ;; Note: this assumes undo-strong-limit > undo-limit; + ;; if not, effectively undo-strong-limit = undo-limit + (> (undo-tree-size buffer-undo-tree) undo-limit) + (> (- (undo-tree-size buffer-undo-tree) + ;; if next node to discard is root, the memory we + ;; free-up comes from discarding changesets from its + ;; only child... + (if (eq node (undo-tree-root buffer-undo-tree)) + (+ (undo-list-byte-size + (undo-tree-node-undo + (car (undo-tree-node-next node)))) + (undo-list-byte-size + (undo-tree-node-redo + (car (undo-tree-node-next node))))) + ;; ...otherwise, it comes from discarding changesets + ;; from along with the node itself + (+ (undo-list-byte-size (undo-tree-node-undo node)) + (undo-list-byte-size (undo-tree-node-redo node))) + )) + undo-limit)) + (setq node (undo-tree-discard-node node) + discarded t)) + + (when discarded + (message "Undo history discarded by undo-tree (see `undo-tree-limit')")) + + ;; if we're still over the `undo-outer-limit', discard entire history + (when (and undo-outer-limit + (> (undo-tree-size buffer-undo-tree) undo-outer-limit)) + ;; query first if `undo-ask-before-discard' is set + (if undo-ask-before-discard + (when (yes-or-no-p + (format + "Buffer `%s' undo info is %d bytes long; discard it? " + (buffer-name) (undo-tree-size buffer-undo-tree))) + (setq buffer-undo-tree nil)) + ;; otherwise, discard and display warning + (display-warning + '(undo discard-info) + (concat + (format "Buffer `%s' undo info was %d bytes long.\n" + (buffer-name) (undo-tree-size buffer-undo-tree)) + "The undo info was discarded because it exceeded\ + `undo-outer-limit'. + +This is normal if you executed a command that made a huge change +to the buffer. In that case, to prevent similar problems in the +future, set `undo-outer-limit' to a value that is large enough to +cover the maximum size of normal changes you expect a single +command to make, but not so large that it might exceed the +maximum memory allotted to Emacs. + +If you did not execute any such command, the situation is +probably due to a bug and you should report it. + +You can disable the popping up of this buffer by adding the entry +\(undo discard-info) to the user option `warning-suppress-types', +which is defined in the `warnings' library.\n") + :warning) + (setq buffer-undo-tree nil))) + + ;; if currently displaying the visualizer, redraw it + (when (and buffer-undo-tree + discarded + (or (eq major-mode 'undo-tree-visualizer-mode) + undo-tree-visualizer-parent-buffer + (get-buffer undo-tree-visualizer-buffer-name))) + (let ((undo-tree buffer-undo-tree)) + (with-current-buffer undo-tree-visualizer-buffer-name + (undo-tree-draw-tree undo-tree) + (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff))))) + ))) + + + + +;;; ===================================================================== +;;; Visualizer utility functions + +(defun undo-tree-compute-widths (node) + "Recursively compute widths for nodes below NODE." + (let ((stack (list node)) + res) + (while stack + ;; try to compute widths for node at top of stack + (if (undo-tree-node-p + (setq res (undo-tree-node-compute-widths (car stack)))) + ;; if computation fails, it returns a node whose widths still need + ;; computing, which we push onto the stack + (push res stack) + ;; otherwise, store widths and remove it from stack + (setf (undo-tree-node-lwidth (car stack)) (aref res 0) + (undo-tree-node-cwidth (car stack)) (aref res 1) + (undo-tree-node-rwidth (car stack)) (aref res 2)) + (pop stack))))) + + +(defun undo-tree-node-compute-widths (node) + ;; Compute NODE's left-, centre-, and right-subtree widths. Returns widths + ;; (in a vector) if successful. Otherwise, returns a node whose widths need + ;; calculating before NODE's can be calculated. + (let ((num-children (length (undo-tree-node-next node))) + (lwidth 0) (cwidth 0) (rwidth 0) p) + (catch 'need-widths + (cond + ;; leaf nodes have 0 width + ((= 0 num-children) + (setf cwidth 1 + (undo-tree-node-lwidth node) 0 + (undo-tree-node-cwidth node) 1 + (undo-tree-node-rwidth node) 0)) + + ;; odd number of children + ((= (mod num-children 2) 1) + (setq p (undo-tree-node-next node)) + ;; compute left-width + (dotimes (_ (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (cl-incf lwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + ;; if child's widths haven't been computed, return that child + (throw 'need-widths (car p))) + (setq p (cdr p))) + (if (undo-tree-node-lwidth (car p)) + (cl-incf lwidth (undo-tree-node-lwidth (car p))) + (throw 'need-widths (car p))) + ;; centre-width is inherited from middle child + (setf cwidth (undo-tree-node-cwidth (car p))) + ;; compute right-width + (cl-incf rwidth (undo-tree-node-rwidth (car p))) + (setq p (cdr p)) + (dotimes (_ (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (cl-incf rwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + (throw 'need-widths (car p))) + (setq p (cdr p)))) + + ;; even number of children + (t + (setq p (undo-tree-node-next node)) + ;; compute left-width + (dotimes (_ (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (cl-incf lwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + (throw 'need-widths (car p))) + (setq p (cdr p))) + ;; centre-width is 0 when number of children is even + (setq cwidth 0) + ;; compute right-width + (dotimes (_ (/ num-children 2)) + (if (undo-tree-node-lwidth (car p)) + (cl-incf rwidth (+ (undo-tree-node-lwidth (car p)) + (undo-tree-node-cwidth (car p)) + (undo-tree-node-rwidth (car p)))) + (throw 'need-widths (car p))) + (setq p (cdr p))))) + + ;; return left-, centre- and right-widths + (vector lwidth cwidth rwidth)))) + + +(defun undo-tree-clear-visualizer-data (tree) + ;; Clear visualizer data below NODE. + (undo-tree-mapc + (lambda (n) (undo-tree-node-clear-visualizer-data n)) + (undo-tree-root tree))) + + +(defun undo-tree-node-unmodified-p (node &optional mtime) + ;; Return non-nil if NODE corresponds to a buffer state that once upon a + ;; time was unmodified. If a file modification time MTIME is specified, + ;; return non-nil if the corresponding buffer state really is unmodified. + (let* ((changeset + (or (undo-tree-node-redo node) + (and (setq changeset (car (undo-tree-node-next node))) + (undo-tree-node-undo changeset)))) + (ntime + (let ((elt (car (last changeset)))) + (and (consp elt) (eq (car elt) t) (consp (cdr elt)) + (cdr elt))))) + (and ntime + (or (null mtime) + ;; high-precision timestamps + (if (listp (cdr ntime)) + (equal ntime mtime) + ;; old-style timestamps + (and (= (car ntime) (car mtime)) + (= (cdr ntime) (cadr mtime)))))))) + + + + +;;; ===================================================================== +;;; Undo-in-region utility functions + +;; `undo-elt-in-region' uses this as a dynamically-scoped variable +(defvar undo-adjusted-markers nil) + + +(defun undo-tree-pull-undo-in-region-branch (start end) + ;; Pull out entries from undo changesets to create a new undo-in-region + ;; branch, which undoes changeset entries lying between START and END first, + ;; followed by remaining entries from the changesets, before rejoining the + ;; existing undo tree history. Repeated calls will, if appropriate, extend + ;; the current undo-in-region branch rather than creating a new one. + + ;; if we're just reverting the last redo-in-region, we don't need to + ;; manipulate the undo tree at all + (if (undo-tree-reverting-redo-in-region-p start end) + t ; return t to indicate success + + ;; We build the `region-changeset' and `delta-list' lists forwards, using + ;; pointers `r' and `d' to the penultimate element of the list. So that we + ;; don't have to treat the first element differently, we prepend a dummy + ;; leading nil to the lists, and have the pointers point to that + ;; initially. + ;; Note: using '(nil) instead of (list nil) in the `let*' results in + ;; errors when the code is byte-compiled, presumably because the + ;; Lisp reader generates a single cons, and that same cons gets used + ;; each call. + (let* ((region-changeset (list nil)) + (r region-changeset) + (delta-list (list nil)) + (d delta-list) + (node (undo-tree-current buffer-undo-tree)) + (repeated-undo-in-region + (undo-tree-repeated-undo-in-region-p start end)) + undo-adjusted-markers ; `undo-elt-in-region' expects this + fragment splice original-fragment original-splice original-current + got-visible-elt undo-list elt) + + ;; --- initialisation --- + (cond + ;; if this is a repeated undo in the same region, start pulling changes + ;; from NODE at which undo-in-region branch is attached, and detatch + ;; the branch, using it as initial FRAGMENT of branch being constructed + (repeated-undo-in-region + (setq original-current node + fragment (car (undo-tree-node-next node)) + splice node) + ;; undo up to node at which undo-in-region branch is attached + ;; (recognizable as first node with more than one branch) + (let ((mark-active nil)) + (while (= (length (undo-tree-node-next node)) 1) + (undo-tree-undo-1) + (setq fragment node + node (undo-tree-current buffer-undo-tree)))) + (when (eq splice node) (setq splice nil)) + ;; detatch undo-in-region branch + (setf (undo-tree-node-next node) + (delq fragment (undo-tree-node-next node)) + (undo-tree-node-previous fragment) nil + original-fragment fragment + original-splice node)) + + ;; if this is a new undo-in-region, initial FRAGMENT is a copy of all + ;; nodes below the current one in the active branch + ((undo-tree-node-next node) + (setq fragment (undo-tree-make-node nil nil) + splice fragment) + (while (setq node (nth (undo-tree-node-branch node) + (undo-tree-node-next node))) + (push (undo-tree-make-node + splice + (undo-copy-list (undo-tree-node-undo node)) + (undo-copy-list (undo-tree-node-redo node))) + (undo-tree-node-next splice)) + (setq splice (car (undo-tree-node-next splice)))) + (setq fragment (car (undo-tree-node-next fragment)) + splice nil + node (undo-tree-current buffer-undo-tree)))) + + + ;; --- pull undo-in-region elements into branch --- + ;; work backwards up tree, pulling out undo elements within region until + ;; we've got one that undoes a visible change (insertion or deletion) + (catch 'abort + (while (and (not got-visible-elt) node (undo-tree-node-undo node)) + ;; we cons a dummy nil element on the front of the changeset so that + ;; we can conveniently remove the first (real) element from the + ;; changeset if we need to; the leading nil is removed once we're + ;; done with this changeset + (setq undo-list (cons nil (undo-copy-list (undo-tree-node-undo node))) + elt (cadr undo-list)) + (if fragment + (progn + (setq fragment (undo-tree-grow-backwards fragment undo-list)) + (unless splice (setq splice fragment))) + (setq fragment (undo-tree-make-node nil undo-list)) + (setq splice fragment)) + + (while elt + (cond + ;; keep elements within region + ((undo-elt-in-region elt start end) + ;; set flag if kept element is visible (insertion or deletion) + (when (and (consp elt) + (or (stringp (car elt)) (integerp (car elt)))) + (setq got-visible-elt t)) + ;; adjust buffer positions in elements previously undone before + ;; kept element, as kept element will now be undone first + (undo-tree-adjust-elements-to-elt splice elt) + ;; move kept element to undo-in-region changeset, adjusting its + ;; buffer position as it will now be undone first + (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list)))) + (setq r (cdr r)) + (setcdr undo-list (cddr undo-list))) + + ;; discard "was unmodified" elements + ;; FIXME: deal properly with these + ((and (consp elt) (eq (car elt) t)) + (setcdr undo-list (cddr undo-list))) + + ;; if element crosses region, we can't pull any more elements + ((undo-elt-crosses-region elt start end) + ;; if we've found a visible element, it must be earlier in + ;; current node's changeset; stop pulling elements (null + ;; `undo-list' and non-nil `got-visible-elt' cause loop to exit) + (if got-visible-elt + (setq undo-list nil) + ;; if we haven't found a visible element yet, pulling + ;; undo-in-region branch has failed + (setq region-changeset nil) + (throw 'abort t))) + + ;; if rejecting element, add its delta (if any) to the list + (t + (let ((delta (undo-delta elt))) + (when (/= 0 (cdr delta)) + (setcdr d (list delta)) + (setq d (cdr d)))) + (setq undo-list (cdr undo-list)))) + + ;; process next element of current changeset + (setq elt (cadr undo-list))) + + ;; if there are remaining elements in changeset, remove dummy nil + ;; from front + (if (cadr (undo-tree-node-undo fragment)) + (pop (undo-tree-node-undo fragment)) + ;; otherwise, if we've kept all elements in changeset, discard + ;; empty changeset + (when (eq splice fragment) (setq splice nil)) + (setq fragment (car (undo-tree-node-next fragment)))) + ;; process changeset from next node up the tree + (setq node (undo-tree-node-previous node)))) + + ;; pop dummy nil from front of `region-changeset' + (setq region-changeset (cdr region-changeset)) + + + ;; --- integrate branch into tree --- + ;; if no undo-in-region elements were found, restore undo tree + (if (null region-changeset) + (when original-current + (push original-fragment (undo-tree-node-next original-splice)) + (setf (undo-tree-node-branch original-splice) 0 + (undo-tree-node-previous original-fragment) original-splice) + (let ((mark-active nil)) + (while (not (eq (undo-tree-current buffer-undo-tree) + original-current)) + (undo-tree-redo-1))) + nil) ; return nil to indicate failure + + ;; otherwise... + ;; need to undo up to node where new branch will be attached, to + ;; ensure redo entries are populated, and then redo back to where we + ;; started + (let ((mark-active nil) + (current (undo-tree-current buffer-undo-tree))) + (while (not (eq (undo-tree-current buffer-undo-tree) node)) + (undo-tree-undo-1)) + (while (not (eq (undo-tree-current buffer-undo-tree) current)) + (undo-tree-redo-1))) + + (cond + ;; if there's no remaining fragment, just create undo-in-region node + ;; and attach it to parent of last node from which elements were + ;; pulled + ((null fragment) + (setq fragment (undo-tree-make-node node region-changeset)) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0) + ;; set current node to undo-in-region node + (setf (undo-tree-current buffer-undo-tree) fragment)) + + ;; if no splice point has been set, add undo-in-region node to top of + ;; fragment and attach it to parent of last node from which elements + ;; were pulled + ((null splice) + (setq fragment (undo-tree-grow-backwards fragment region-changeset)) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0 + (undo-tree-node-previous fragment) node) + ;; set current node to undo-in-region node + (setf (undo-tree-current buffer-undo-tree) fragment)) + + ;; if fragment contains nodes, attach fragment to parent of last node + ;; from which elements were pulled, and splice in undo-in-region node + (t + (setf (undo-tree-node-previous fragment) node) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0) + ;; if this is a repeated undo-in-region, then we've left the current + ;; node at the original splice-point; we need to set the current + ;; node to the equivalent node on the undo-in-region branch and redo + ;; back to where we started + (when repeated-undo-in-region + (setf (undo-tree-current buffer-undo-tree) + (undo-tree-node-previous original-fragment)) + (let ((mark-active nil)) + (while (not (eq (undo-tree-current buffer-undo-tree) splice)) + (undo-tree-redo-1 nil 'preserve-undo)))) + ;; splice new undo-in-region node into fragment + (setq node (undo-tree-make-node nil region-changeset)) + (undo-tree-splice-node node splice) + ;; set current node to undo-in-region node + (setf (undo-tree-current buffer-undo-tree) node))) + + ;; update undo-tree size + (setq node (undo-tree-node-previous fragment)) + (while (progn + (and (setq node (car (undo-tree-node-next node))) + (not (eq node original-fragment)) + (cl-incf (undo-tree-count buffer-undo-tree)) + (cl-incf (undo-tree-size buffer-undo-tree) + (+ (undo-list-byte-size (undo-tree-node-undo node)) + (undo-list-byte-size (undo-tree-node-redo node))))))) + t) ; indicate undo-in-region branch was successfully pulled + ))) + + + +(defun undo-tree-pull-redo-in-region-branch (start end) + ;; Pull out entries from redo changesets to create a new redo-in-region + ;; branch, which redoes changeset entries lying between START and END first, + ;; followed by remaining entries from the changesets. Repeated calls will, + ;; if appropriate, extend the current redo-in-region branch rather than + ;; creating a new one. + + ;; if we're just reverting the last undo-in-region, we don't need to + ;; manipulate the undo tree at all + (if (undo-tree-reverting-undo-in-region-p start end) + t ; return t to indicate success + + ;; We build the `region-changeset' and `delta-list' lists forwards, using + ;; pointers `r' and `d' to the penultimate element of the list. So that we + ;; don't have to treat the first element differently, we prepend a dummy + ;; leading nil to the lists, and have the pointers point to that + ;; initially. + ;; Note: using '(nil) instead of (list nil) in the `let*' causes bizarre + ;; errors when the code is byte-compiled, where parts of the lists + ;; appear to survive across different calls to this function. An + ;; obscure byte-compiler bug, perhaps? + (let* ((region-changeset (list nil)) + (r region-changeset) + (delta-list (list nil)) + (d delta-list) + (node (undo-tree-current buffer-undo-tree)) + (repeated-redo-in-region + (undo-tree-repeated-redo-in-region-p start end)) + undo-adjusted-markers ; `undo-elt-in-region' expects this + fragment splice got-visible-elt redo-list elt) + + ;; --- inisitalisation --- + (cond + ;; if this is a repeated redo-in-region, detach fragment below current + ;; node + (repeated-redo-in-region + (when (setq fragment (car (undo-tree-node-next node))) + (setf (undo-tree-node-previous fragment) nil + (undo-tree-node-next node) + (delq fragment (undo-tree-node-next node))))) + ;; if this is a new redo-in-region, initial fragment is a copy of all + ;; nodes below the current one in the active branch + ((undo-tree-node-next node) + (setq fragment (undo-tree-make-node nil nil) + splice fragment) + (while (setq node (nth (undo-tree-node-branch node) + (undo-tree-node-next node))) + (push (undo-tree-make-node + splice nil + (undo-copy-list (undo-tree-node-redo node))) + (undo-tree-node-next splice)) + (setq splice (car (undo-tree-node-next splice)))) + (setq fragment (car (undo-tree-node-next fragment))))) + + + ;; --- pull redo-in-region elements into branch --- + ;; work down fragment, pulling out redo elements within region until + ;; we've got one that redoes a visible change (insertion or deletion) + (setq node fragment) + (catch 'abort + (while (and (not got-visible-elt) node (undo-tree-node-redo node)) + ;; we cons a dummy nil element on the front of the changeset so that + ;; we can conveniently remove the first (real) element from the + ;; changeset if we need to; the leading nil is removed once we're + ;; done with this changeset + (setq redo-list (push nil (undo-tree-node-redo node)) + elt (cadr redo-list)) + (while elt + (cond + ;; keep elements within region + ((undo-elt-in-region elt start end) + ;; set flag if kept element is visible (insertion or deletion) + (when (and (consp elt) + (or (stringp (car elt)) (integerp (car elt)))) + (setq got-visible-elt t)) + ;; adjust buffer positions in elements previously redone before + ;; kept element, as kept element will now be redone first + (undo-tree-adjust-elements-to-elt fragment elt t) + ;; move kept element to redo-in-region changeset, adjusting its + ;; buffer position as it will now be redone first + (setcdr r (list (undo-tree-apply-deltas elt (cdr delta-list) -1))) + (setq r (cdr r)) + (setcdr redo-list (cddr redo-list))) + + ;; discard "was unmodified" elements + ;; FIXME: deal properly with these + ((and (consp elt) (eq (car elt) t)) + (setcdr redo-list (cddr redo-list))) + + ;; if element crosses region, we can't pull any more elements + ((undo-elt-crosses-region elt start end) + ;; if we've found a visible element, it must be earlier in + ;; current node's changeset; stop pulling elements (null + ;; `redo-list' and non-nil `got-visible-elt' cause loop to exit) + (if got-visible-elt + (setq redo-list nil) + ;; if we haven't found a visible element yet, pulling + ;; redo-in-region branch has failed + (setq region-changeset nil) + (throw 'abort t))) + + ;; if rejecting element, add its delta (if any) to the list + (t + (let ((delta (undo-delta elt))) + (when (/= 0 (cdr delta)) + (setcdr d (list delta)) + (setq d (cdr d)))) + (setq redo-list (cdr redo-list)))) + + ;; process next element of current changeset + (setq elt (cadr redo-list))) + + ;; if there are remaining elements in changeset, remove dummy nil + ;; from front + (if (cadr (undo-tree-node-redo node)) + (pop (undo-tree-node-undo node)) + ;; otherwise, if we've kept all elements in changeset, discard + ;; empty changeset + (if (eq fragment node) + (setq fragment (car (undo-tree-node-next fragment))) + (undo-tree-snip-node node))) + ;; process changeset from next node in fragment + (setq node (car (undo-tree-node-next node))))) + + ;; pop dummy nil from front of `region-changeset' + (setq region-changeset (cdr region-changeset)) + + + ;; --- integrate branch into tree --- + (setq node (undo-tree-current buffer-undo-tree)) + ;; if no redo-in-region elements were found, restore undo tree + (if (null (car region-changeset)) + (when (and repeated-redo-in-region fragment) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0 + (undo-tree-node-previous fragment) node) + nil) ; return nil to indicate failure + + ;; otherwise, add redo-in-region node to top of fragment, and attach + ;; it below current node + (setq fragment + (if fragment + (undo-tree-grow-backwards fragment nil region-changeset) + (undo-tree-make-node nil nil region-changeset))) + (push fragment (undo-tree-node-next node)) + (setf (undo-tree-node-branch node) 0 + (undo-tree-node-previous fragment) node) + ;; update undo-tree size + (unless repeated-redo-in-region + (setq node fragment) + (while (and (setq node (car (undo-tree-node-next node))) + (cl-incf (undo-tree-count buffer-undo-tree)) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size + (undo-tree-node-redo node)))))) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo fragment))) + t) ; indicate redo-in-region branch was successfully pulled + ))) + + + +(defun undo-tree-adjust-elements-to-elt (node undo-elt &optional below) + "Adjust buffer positions of undo elements, starting at NODE's +and going up the tree (or down the active branch if BELOW is +non-nil) and through the nodes' undo elements until we reach +UNDO-ELT. UNDO-ELT must appear somewhere in the undo changeset +of either NODE itself or some node above it in the tree." + (let ((delta (list (undo-delta undo-elt))) + (undo-list (undo-tree-node-undo node))) + ;; adjust elements until we reach UNDO-ELT + (while (and (car undo-list) + (not (eq (car undo-list) undo-elt))) + (setcar undo-list + (undo-tree-apply-deltas (car undo-list) delta -1)) + ;; move to next undo element in list, or to next node if we've run out + ;; of elements + (unless (car (setq undo-list (cdr undo-list))) + (if below + (setq node (nth (undo-tree-node-branch node) + (undo-tree-node-next node))) + (setq node (undo-tree-node-previous node))) + (setq undo-list (undo-tree-node-undo node)))))) + + + +(defun undo-tree-apply-deltas (undo-elt deltas &optional sgn) + ;; Apply DELTAS in order to UNDO-ELT, multiplying deltas by SGN + ;; (only useful value for SGN is -1). + (let (position offset) + (dolist (delta deltas) + (setq position (car delta) + offset (* (cdr delta) (or sgn 1))) + (cond + ;; POSITION + ((integerp undo-elt) + (when (>= undo-elt position) + (setq undo-elt (- undo-elt offset)))) + ;; nil (or any other atom) + ((atom undo-elt)) + ;; (TEXT . POSITION) + ((stringp (car undo-elt)) + (let ((text-pos (abs (cdr undo-elt))) + (point-at-end (< (cdr undo-elt) 0))) + (if (>= text-pos position) + (setcdr undo-elt (* (if point-at-end -1 1) + (- text-pos offset)))))) + ;; (BEGIN . END) + ((integerp (car undo-elt)) + (when (>= (car undo-elt) position) + (setcar undo-elt (- (car undo-elt) offset)) + (setcdr undo-elt (- (cdr undo-elt) offset)))) + ;; (nil PROPERTY VALUE BEG . END) + ((null (car undo-elt)) + (let ((tail (nthcdr 3 undo-elt))) + (when (>= (car tail) position) + (setcar tail (- (car tail) offset)) + (setcdr tail (- (cdr tail) offset))))) + )) + undo-elt)) + + + +(defun undo-tree-repeated-undo-in-region-p (start end) + ;; Return non-nil if undo-in-region between START and END is a repeated + ;; undo-in-region + (let ((node (undo-tree-current buffer-undo-tree))) + (and (setq node + (nth (undo-tree-node-branch node) (undo-tree-node-next node))) + (eq (undo-tree-node-undo-beginning node) start) + (eq (undo-tree-node-undo-end node) end)))) + + +(defun undo-tree-repeated-redo-in-region-p (start end) + ;; Return non-nil if undo-in-region between START and END is a repeated + ;; undo-in-region + (let ((node (undo-tree-current buffer-undo-tree))) + (and (eq (undo-tree-node-redo-beginning node) start) + (eq (undo-tree-node-redo-end node) end)))) + + +;; Return non-nil if undo-in-region between START and END is simply +;; reverting the last redo-in-region +(defalias 'undo-tree-reverting-undo-in-region-p + 'undo-tree-repeated-undo-in-region-p) + + +;; Return non-nil if redo-in-region between START and END is simply +;; reverting the last undo-in-region +(defalias 'undo-tree-reverting-redo-in-region-p + 'undo-tree-repeated-redo-in-region-p) + + + + +;;; ===================================================================== +;;; Undo-tree commands + +(defvar undo-tree-timer nil) + +;;;###autoload +(define-minor-mode undo-tree-mode + "Toggle undo-tree mode. +With no argument, this command toggles the mode. +A positive prefix argument turns the mode on. +A negative prefix argument turns it off. + +Undo-tree-mode replaces Emacs' standard undo feature with a more +powerful yet easier to use version, that treats the undo history +as what it is: a tree. + +The following keys are available in `undo-tree-mode': + + \\{undo-tree-map} + +Within the undo-tree visualizer, the following keys are available: + + \\{undo-tree-visualizer-mode-map}" + + nil ; init value + undo-tree-mode-lighter ; lighter + undo-tree-map ; keymap + + (cond + (undo-tree-mode ; enabling `undo-tree-mode' + (set (make-local-variable 'undo-limit) + (if undo-tree-limit + (max undo-limit undo-tree-limit) + most-positive-fixnum)) + (set (make-local-variable 'undo-strong-limit) + (if undo-tree-limit + (max undo-strong-limit undo-tree-strong-limit) + most-positive-fixnum)) + (set (make-local-variable 'undo-outer-limit) ; null `undo-outer-limit' means no limit + (when (and undo-tree-limit undo-outer-limit undo-outer-limit) + (max undo-outer-limit undo-tree-outer-limit))) + (when (null undo-tree-limit) + (setq undo-tree-timer + (run-with-idle-timer 5 'repeat #'undo-list-transfer-to-tree))) + (add-hook 'post-gc-hook #'undo-tree-post-gc nil)) + + (t ; disabling `undo-tree-mode' + ;; rebuild `buffer-undo-list' from tree so Emacs undo can work + (undo-list-rebuild-from-tree) + (setq buffer-undo-tree nil) + (remove-hook 'post-gc-hook #'undo-tree-post-gc 'local) + (when (timerp undo-tree-timer) (cancel-timer undo-tree-timer)) + (kill-local-variable 'undo-limit) + (kill-local-variable 'undo-strong-limit) + (kill-local-variable 'undo-outer-limit)))) + + +(defun turn-on-undo-tree-mode (&optional print-message) + "Enable `undo-tree-mode' in the current buffer, when appropriate. +Some major modes implement their own undo system, which should +not normally be overridden by `undo-tree-mode'. This command does +not enable `undo-tree-mode' in such buffers. If you want to force +`undo-tree-mode' to be enabled regardless, use (undo-tree-mode 1) +instead. + +The heuristic used to detect major modes in which +`undo-tree-mode' should not be used is to check whether either +the `undo' command has been remapped, or the default undo +keybindings (C-/ and C-_) have been overridden somewhere other +than in the global map. In addition, `undo-tree-mode' will not be +enabled if the buffer's `major-mode' appears in +`undo-tree-incompatible-major-modes'." + (interactive "p") + (if (or (key-binding [remap undo]) + (undo-tree-overridden-undo-bindings-p) + (memq major-mode undo-tree-incompatible-major-modes)) + (when print-message + (message "Buffer does not support undo-tree-mode;\ + undo-tree-mode NOT enabled")) + (undo-tree-mode 1))) + + +(defun undo-tree-overridden-undo-bindings-p () + "Returns t if default undo bindings are overridden, nil otherwise. +Checks if either of the default undo key bindings (\"C-/\" or +\"C-_\") are overridden in the current buffer by any keymap other +than the global one. (So global redefinitions of the default undo +key bindings do not count.)" + (let ((binding1 (lookup-key (current-global-map) [?\C-/])) + (binding2 (lookup-key (current-global-map) [?\C-_]))) + (global-set-key [?\C-/] 'undo) + (global-set-key [?\C-_] 'undo) + (unwind-protect + (or (and (key-binding [?\C-/]) + (not (eq (key-binding [?\C-/]) 'undo))) + (and (key-binding [?\C-_]) + (not (eq (key-binding [?\C-_]) 'undo)))) + (global-set-key [?\C-/] binding1) + (global-set-key [?\C-_] binding2)))) + + +;;;###autoload +(define-globalized-minor-mode global-undo-tree-mode + undo-tree-mode turn-on-undo-tree-mode) + + + +(defun undo-tree-undo (&optional arg) + "Undo changes. +Repeat this command to undo more changes. +A numeric ARG serves as a repeat count. + +In Transient Mark mode when the mark is active, only undo changes +within the current region. Similarly, when not in Transient Mark +mode, just \\[universal-argument] as an argument limits undo to +changes within the current region." + (interactive "*P") + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + (undo-tree-undo-1 arg) + ;; inform user if at branch point + (when (> (undo-tree-num-branches) 1) (message "Undo branch point!"))) + + +(defun undo-tree-undo-1 (&optional arg preserve-redo preserve-timestamps) + ;; Internal undo function. An active mark in `transient-mark-mode', or + ;; non-nil ARG otherwise, enables undo-in-region. Non-nil PRESERVE-REDO + ;; causes the existing redo record to be preserved, rather than replacing it + ;; with the new one generated by undoing. Non-nil PRESERVE-TIMESTAMPS + ;; disables updating of timestamps in visited undo-tree nodes. (This latter + ;; should *only* be used when temporarily visiting another undo state and + ;; immediately returning to the original state afterwards. Otherwise, it + ;; could cause history-discarding errors.) + (let ((undo-in-progress t) + (undo-in-region (and undo-tree-enable-undo-in-region + (or (region-active-p) + (and arg (not (numberp arg)))))) + pos current) + ;; transfer entries accumulated in `buffer-undo-list' to + ;; `buffer-undo-tree' + (undo-list-transfer-to-tree) + + (dotimes (_ (or (and (numberp arg) (prefix-numeric-value arg)) 1)) + ;; check if at top of undo tree + (unless (undo-tree-node-previous (undo-tree-current buffer-undo-tree)) + (user-error "No further undo information")) + + ;; if region is active, or a non-numeric prefix argument was supplied, + ;; try to pull out a new branch of changes affecting the region + (when (and undo-in-region + (not (undo-tree-pull-undo-in-region-branch + (region-beginning) (region-end)))) + (user-error "No further undo information for region")) + + ;; remove any GC'd elements from node's undo list + (setq current (undo-tree-current buffer-undo-tree)) + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current))) + (setf (undo-tree-node-undo current) + (undo-list-clean-GCd-elts (undo-tree-node-undo current))) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current))) + ;; undo one record from undo tree + (when undo-in-region + (setq pos (set-marker (make-marker) (point))) + (set-marker-insertion-type pos t)) + (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-undo current))) + (undo-boundary) + + ;; if preserving old redo record, discard new redo entries that + ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd + ;; elements from node's redo list + (if preserve-redo + (progn + (undo-list-pop-changeset buffer-undo-list) + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current))) + (setf (undo-tree-node-redo current) + (undo-list-clean-GCd-elts (undo-tree-node-redo current))) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current)))) + ;; otherwise, record redo entries that `primitive-undo' has added to + ;; `buffer-undo-list' in current node's redo record, replacing + ;; existing entry if one already exists + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current))) + (setf (undo-tree-node-redo current) + (undo-list-pop-changeset buffer-undo-list 'discard-pos)) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current)))) + + ;; rewind current node and update timestamp + (setf (undo-tree-current buffer-undo-tree) + (undo-tree-node-previous (undo-tree-current buffer-undo-tree))) + (unless preserve-timestamps + (setf (undo-tree-node-timestamp (undo-tree-current buffer-undo-tree)) + (current-time))) + + ;; if undoing-in-region, record current node, region and direction so we + ;; can tell if undo-in-region is repeated, and re-activate mark if in + ;; `transient-mark-mode'; if not, erase any leftover data + (if (not undo-in-region) + (undo-tree-node-clear-region-data current) + (goto-char pos) + ;; note: we deliberately want to store the region information in the + ;; node *below* the now current one + (setf (undo-tree-node-undo-beginning current) (region-beginning) + (undo-tree-node-undo-end current) (region-end)) + (set-marker pos nil))) + + ;; undo deactivates mark unless undoing-in-region + (setq deactivate-mark (not undo-in-region)))) + + + +(defun undo-tree-redo (&optional arg) + "Redo changes. A numeric ARG serves as a repeat count. + +In Transient Mark mode when the mark is active, only redo changes +within the current region. Similarly, when not in Transient Mark +mode, just \\[universal-argument] as an argument limits redo to +changes within the current region." + (interactive "*P") + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + (undo-tree-redo-1 arg) + ;; inform user if at branch point + (when (> (undo-tree-num-branches) 1) (message "Undo branch point!"))) + + +(defun undo-tree-redo-1 (&optional arg preserve-undo preserve-timestamps) + ;; Internal redo function. An active mark in `transient-mark-mode', or + ;; non-nil ARG otherwise, enables undo-in-region. Non-nil PRESERVE-UNDO + ;; causes the existing redo record to be preserved, rather than replacing it + ;; with the new one generated by undoing. Non-nil PRESERVE-TIMESTAMPS + ;; disables updating of timestamps in visited undo-tree nodes. (This latter + ;; should *only* be used when temporarily visiting another undo state and + ;; immediately returning to the original state afterwards. Otherwise, it + ;; could cause history-discarding errors.) + (let ((undo-in-progress t) + (redo-in-region (and undo-tree-enable-undo-in-region + (or (region-active-p) + (and arg (not (numberp arg)))))) + pos current) + ;; transfer entries accumulated in `buffer-undo-list' to + ;; `buffer-undo-tree' + (undo-list-transfer-to-tree) + + (dotimes (_ (or (and (numberp arg) (prefix-numeric-value arg)) 1)) + ;; check if at bottom of undo tree + (when (null (undo-tree-node-next (undo-tree-current buffer-undo-tree))) + (user-error "No further redo information")) + + ;; if region is active, or a non-numeric prefix argument was supplied, + ;; try to pull out a new branch of changes affecting the region + (when (and redo-in-region + (not (undo-tree-pull-redo-in-region-branch + (region-beginning) (region-end)))) + (user-error "No further redo information for region")) + + ;; get next node (but DON'T advance current node in tree yet, in case + ;; redoing fails) + (setq current (undo-tree-current buffer-undo-tree) + current (nth (undo-tree-node-branch current) + (undo-tree-node-next current))) + ;; remove any GC'd elements from node's redo list + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current))) + (setf (undo-tree-node-redo current) + (undo-list-clean-GCd-elts (undo-tree-node-redo current))) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-redo current))) + ;; redo one record from undo tree + (when redo-in-region + (setq pos (set-marker (make-marker) (point))) + (set-marker-insertion-type pos t)) + (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-redo current))) + (undo-boundary) + ;; advance current node in tree + (setf (undo-tree-current buffer-undo-tree) current) + + ;; if preserving old undo record, discard new undo entries that + ;; `primitive-undo' has added to `buffer-undo-list', and remove any GC'd + ;; elements from node's redo list + (if preserve-undo + (progn + (undo-list-pop-changeset buffer-undo-list) + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current))) + (setf (undo-tree-node-undo current) + (undo-list-clean-GCd-elts (undo-tree-node-undo current))) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current)))) + ;; otherwise, record undo entries that `primitive-undo' has added to + ;; `buffer-undo-list' in current node's undo record, replacing + ;; existing entry if one already exists + (cl-decf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current))) + (setf (undo-tree-node-undo current) + (undo-list-pop-changeset buffer-undo-list 'discard-pos)) + (cl-incf (undo-tree-size buffer-undo-tree) + (undo-list-byte-size (undo-tree-node-undo current)))) + + ;; update timestamp + (unless preserve-timestamps + (setf (undo-tree-node-timestamp current) (current-time))) + + ;; if redoing-in-region, record current node, region and direction so we + ;; can tell if redo-in-region is repeated, and re-activate mark if in + ;; `transient-mark-mode' + (if (not redo-in-region) + (undo-tree-node-clear-region-data current) + (goto-char pos) + (setf (undo-tree-node-redo-beginning current) (region-beginning) + (undo-tree-node-redo-end current) (region-end)) + (set-marker pos nil))) + + ;; redo deactivates the mark unless redoing-in-region + (setq deactivate-mark (not redo-in-region)))) + + + +(defun undo-tree-switch-branch (branch) + "Switch to a different BRANCH of the undo tree. +This will affect which branch to descend when *redoing* changes +using `undo-tree-redo'." + (interactive (list (or (and prefix-arg (prefix-numeric-value prefix-arg)) + (and (not (eq buffer-undo-list t)) + (undo-list-transfer-to-tree) + (let ((b (undo-tree-node-branch + (undo-tree-current + buffer-undo-tree)))) + (cond + ;; switch to other branch if only 2 + ((= (undo-tree-num-branches) 2) (- 1 b)) + ;; prompt if more than 2 + ((> (undo-tree-num-branches) 2) + (read-number + (format "Branch (0-%d, on %d): " + (1- (undo-tree-num-branches)) b))) + )))))) + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + ;; sanity check branch number + (when (<= (undo-tree-num-branches) 1) + (user-error "Not at undo branch point")) + (when (or (< branch 0) (> branch (1- (undo-tree-num-branches)))) + (user-error "Invalid branch number")) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; switch branch + (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree)) + branch) + (message "Switched to branch %d" branch)) + + +(defun undo-tree-set (node &optional preserve-timestamps) + ;; Set buffer to state corresponding to NODE. Returns intersection point + ;; between path back from current node and path back from selected NODE. + ;; Non-nil PRESERVE-TIMESTAMPS disables updating of timestamps in visited + ;; undo-tree nodes. (This should *only* be used when temporarily visiting + ;; another undo state and immediately returning to the original state + ;; afterwards. Otherwise, it could cause history-discarding errors.) + (let ((path (make-hash-table :test 'eq)) + (n node)) + (puthash (undo-tree-root buffer-undo-tree) t path) + ;; build list of nodes leading back from selected node to root, updating + ;; branches as we go to point down to selected node + (while (progn + (puthash n t path) + (when (undo-tree-node-previous n) + (setf (undo-tree-node-branch (undo-tree-node-previous n)) + (undo-tree-position + n (undo-tree-node-next (undo-tree-node-previous n)))) + (setq n (undo-tree-node-previous n))))) + ;; work backwards from current node until we intersect path back from + ;; selected node + (setq n (undo-tree-current buffer-undo-tree)) + (while (not (gethash n path)) + (setq n (undo-tree-node-previous n))) + ;; ascend tree until intersection node + (while (not (eq (undo-tree-current buffer-undo-tree) n)) + (undo-tree-undo-1 nil nil preserve-timestamps)) + ;; descend tree until selected node + (while (not (eq (undo-tree-current buffer-undo-tree) node)) + (undo-tree-redo-1 nil nil preserve-timestamps)) + n)) ; return intersection node + + + +(defun undo-tree-save-state-to-register (register) + "Store current undo-tree state to REGISTER. +The saved state can be restored using +`undo-tree-restore-state-from-register'. +Argument is a character, naming the register." + (interactive "cUndo-tree state to register: ") + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; save current node to REGISTER + (set-register + register (registerv-make + (undo-tree-make-register-data + (current-buffer) (undo-tree-current buffer-undo-tree)) + :print-func 'undo-tree-register-data-print-func)) + ;; record REGISTER in current node, for visualizer + (setf (undo-tree-node-register (undo-tree-current buffer-undo-tree)) + register)) + + + +(defun undo-tree-restore-state-from-register (register) + "Restore undo-tree state from REGISTER. +The state must be saved using `undo-tree-save-state-to-register'. +Argument is a character, naming the register." + (interactive "*cRestore undo-tree state from register: ") + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; throw error if undo is disabled in buffer, or if register doesn't contain + ;; an undo-tree node + (let ((data (registerv-data (get-register register)))) + (cond + ((eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + ((not (undo-tree-register-data-p data)) + (user-error "Register doesn't contain undo-tree state")) + ((not (eq (current-buffer) (undo-tree-register-data-buffer data))) + (user-error "Register contains undo-tree state for a different buffer"))) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; restore buffer state corresponding to saved node + (undo-tree-set (undo-tree-register-data-node data)))) + + + + +;;; ===================================================================== +;;; Undo-tree menu bar + +(defvar undo-tree-old-undo-menu-item nil) + +(defun undo-tree-update-menu-bar () + "Update `undo-tree-mode' Edit menu items." + (if undo-tree-mode + (progn + ;; save old undo menu item, and install undo/redo menu items + (setq undo-tree-old-undo-menu-item + (cdr (assq 'undo (lookup-key global-map [menu-bar edit])))) + (define-key (lookup-key global-map [menu-bar edit]) + [undo] '(menu-item "Undo" undo-tree-undo + :enable (and undo-tree-mode + (not buffer-read-only) + (not (eq t buffer-undo-list)) + (not (eq nil buffer-undo-tree)) + (undo-tree-node-previous + (undo-tree-current buffer-undo-tree))) + :help "Undo last operation")) + (define-key-after (lookup-key global-map [menu-bar edit]) + [redo] '(menu-item "Redo" undo-tree-redo + :enable (and undo-tree-mode + (not buffer-read-only) + (not (eq t buffer-undo-list)) + (not (eq nil buffer-undo-tree)) + (undo-tree-node-next + (undo-tree-current buffer-undo-tree))) + :help "Redo last operation") + 'undo)) + ;; uninstall undo/redo menu items + (define-key (lookup-key global-map [menu-bar edit]) + [undo] undo-tree-old-undo-menu-item) + (define-key (lookup-key global-map [menu-bar edit]) + [redo] nil))) + +(add-hook 'menu-bar-update-hook 'undo-tree-update-menu-bar) + + + + +;;; ===================================================================== +;;; Persistent storage commands + +(defvar undo-tree-save-format-version 1 + "Undo-tree history file format version.") + + +(defun undo-tree-make-history-save-file-name (file) + "Create the undo history file name for FILE. +Normally this is the file's name with \".\" prepended and +\".~undo-tree~\" appended. + +A match for FILE is sought in `undo-tree-history-directory-alist' +\(see the documentation of that variable for details\). If the +directory for the backup doesn't exist, it is created." + (let* ((backup-directory-alist undo-tree-history-directory-alist) + (name (make-backup-file-name-1 file))) + (concat (file-name-directory name) "." (file-name-nondirectory name) + ".~undo-tree~"))) + + +(defun undo-tree-serialize (tree) + "Serialise undo-tree TREE to current buffer." + ;; write root + (let ((data (undo-tree-copy-node-save-data (undo-tree-root tree)))) + (when (eq (undo-tree-root tree) (undo-tree-current tree)) + (setf (undo-tree-node-next data) 'current)) + (prin1 data (current-buffer))) + (terpri (current-buffer)) + ;; Note: We serialise in breadth-first order, as undo-trees are typically + ;; much deeper than they are wide, so this is more memory-efficient. + (let ((queue (make-queue))) + (queue-enqueue queue (undo-tree-root tree)) + (while (not (queue-empty queue)) + (prin1 (mapcar + (lambda (n) + (queue-enqueue queue n) + (let ((data (undo-tree-copy-node-save-data n))) + ;; use empty next field to mark current node + (when (eq n (undo-tree-current tree)) + (setf (undo-tree-node-next data) 'current)) + data)) + (undo-tree-node-next (queue-dequeue queue))) + (current-buffer)) + (terpri (current-buffer))))) + + +(defun undo-tree-deserialize () + "Deserialize and return undo-tree from current buffer." + (let ((tree (make-undo-tree)) + (queue (make-queue)) + node) + ;; read root + (setf (undo-tree-root tree) (read (current-buffer))) + (queue-enqueue queue (undo-tree-root tree)) + ;; reconstruct tree in breadth-first order + (while (not (queue-empty queue)) + (setq node (queue-dequeue queue)) + (when (eq (undo-tree-node-next node) 'current) + (setf (undo-tree-current tree) node)) + (setf (undo-tree-node-next node) (read (current-buffer))) + (mapc (lambda (n) (queue-enqueue queue n)) + (undo-tree-node-next node))) + ;; restore parent links + (undo-tree-recircle tree) + tree)) + + +(defun undo-tree-serialize-old-format (tree) + ;; make tmp copy of TREE + (setq tree (undo-tree-copy tree)) + ;; decircle and discard object pool before saving + (undo-tree-decircle tree) + (setf (undo-tree-object-pool tree) nil) + ;; run pre-save transformer functions + (when undo-tree-pre-save-element-functions + (undo-tree-mapc + (lambda (node) + (let ((changeset (undo-tree-node-undo node))) + (run-hook-wrapped + 'undo-tree-pre-save-element-functions + (lambda (fun) + (setq changeset (delq nil (mapcar fun changeset))) + nil)) + (setf (undo-tree-node-undo node) changeset)) + (let ((changeset (undo-tree-node-redo node))) + (run-hook-wrapped + 'undo-tree-pre-save-element-functions + (lambda (fun) + (setq changeset (delq nil (mapcar fun changeset))) + nil)) + (setf (undo-tree-node-redo node) changeset))) + (undo-tree-root tree))) + ;; write tree + (let ((print-circle t)) (prin1 tree (current-buffer)))) + + +(defun undo-tree-deserialize-old-format () + ;; read tree + (let ((tree (read (current-buffer)))) + ;; run post-load transformer functions + (when undo-tree-post-load-element-functions + (undo-tree-mapc + (lambda (node) + (let ((changeset (undo-tree-node-undo node))) + (run-hook-wrapped + 'undo-tree-post-load-element-functions + (lambda (fun) + (setq changeset (delq nil (mapcar fun changeset))))) + (setf (undo-tree-node-undo node) changeset)) + (let ((changeset (undo-tree-node-redo node))) + (run-hook-wrapped + 'undo-tree-post-load-element-functions + (lambda (fun) + (setq changeset (delq nil (mapcar fun changeset))))) + (setf (undo-tree-node-redo node) changeset))) + (undo-tree-root tree))) + ;; initialise empty undo-tree object pool + (setf (undo-tree-object-pool tree) + (make-hash-table :test 'eq :weakness 'value)) + ;; restore parent links + (undo-tree-recircle tree) + tree)) + + + +(defun undo-tree-save-history (&optional filename overwrite) + "Store undo-tree history to file. + +If optional argument FILENAME is omitted, default save file is +\"..~undo-tree\" if buffer is visiting a file. +Otherwise, prompt for one. + +If OVERWRITE is non-nil, any existing file will be overwritten +without asking for confirmation." + (interactive) + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + (undo-list-transfer-to-tree) + (when (and buffer-undo-tree (not (eq buffer-undo-tree t))) + ;; (undo-tree-kill-visualizer) + ;; ;; should be cleared already by killing the visualizer, but writes + ;; ;; unreasable data if not for some reason, so just in case... + ;; (undo-tree-clear-visualizer-data buffer-undo-tree) + (let ((buff (current-buffer)) + (tree buffer-undo-tree)) + ;; get filename + (unless filename + (setq filename + (if buffer-file-name + (undo-tree-make-history-save-file-name buffer-file-name) + (expand-file-name (read-file-name "File to save in: ") nil)))) + (when (or (not (file-exists-p filename)) + overwrite + (yes-or-no-p (format "Overwrite \"%s\"? " filename))) + + ;; print undo-tree to file + ;; Note: We use `with-temp-buffer' instead of `with-temp-file' to + ;; allow `auto-compression-mode' to take effect, in case user + ;; has overridden or advised the default + ;; `undo-tree-make-history-save-file-name' to add a compressed + ;; file extension. + (with-temp-buffer + ;; write version number; (original save file format (version 0) has no version string) + (unless (= undo-tree-save-format-version 0) + (prin1 (cons 'undo-tree-save-format-version undo-tree-save-format-version) + (current-buffer)) + (terpri (current-buffer))) + ;; write hash + (prin1 (sha1 buff) (current-buffer)) + (terpri (current-buffer)) + ;; write tree + (cl-case undo-tree-save-format-version + (0 (undo-tree-serialize-old-format tree)) + (1 (undo-tree-serialize tree)) + (t (error "Unknown `undo-tree-save-format-version'; undo-tree history *not* saved"))) + ;; write file + (with-auto-compression-mode + (write-region nil nil filename))))))) + + +(defmacro undo-tree--catch-load-history-error (error-fmt &rest body) + `(condition-case nil + (progn ,@body) + (error + (kill-buffer nil) + (funcall (if noerror #'message #'user-error) ,error-fmt filename) + (throw 'load-error nil)))) + + +(defun undo-tree-load-history (&optional filename noerror) + "Load undo-tree history from file, for the current buffer. + +If optional argument FILENAME is null, default load file is +\"..~undo-tree\" if buffer is visiting a file. +Otherwise, prompt for one. + +If optional argument NOERROR is non-nil, return nil instead of +signaling an error if file is not found. + +Note this will overwrite any existing undo history." + (interactive) + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + ;; get filename + (unless filename + (setq filename + (if buffer-file-name + (undo-tree-make-history-save-file-name buffer-file-name) + (expand-file-name (read-file-name "File to load from: ") nil)))) + + ;; attempt to read undo-tree + (catch 'load-error + (unless (file-exists-p filename) + (if noerror + (throw 'load-error nil) + (user-error "File \"%s\" does not exist; could not load undo-tree history" + filename))) + + ;; read file contents + (let ((buff (current-buffer)) + version hash tree) + (with-temp-buffer + (with-auto-compression-mode (insert-file-contents filename)) + (goto-char (point-min)) + + (undo-tree--catch-load-history-error + "Error reading undo-tree history from \"%s\"" + ;; read version number + (setq version (read (current-buffer))) + ;; read hash + (cond + ((eq (car-safe version) 'undo-tree-save-format-version) + (setq version (cdr version)) + (setq hash (read (current-buffer)))) + ;; original save file format (version 0) has no version string + ((stringp version) + (setq hash version + version 0)) + (t (error "Error")))) + + ;; check hash + (undo-tree--catch-load-history-error + "Buffer has been modified since undo-tree history was saved to + \"%s\"; could not load undo-tree history" + (unless (string= (sha1 buff) hash) (error "Error"))) + + ;; read tree + (undo-tree--catch-load-history-error + "Error reading undo-tree history from \"%s\"" + (setq tree + (cl-case version + (0 (undo-tree-deserialize-old-format)) + (1 (undo-tree-deserialize)) + (t (error "Error"))))) + (kill-buffer nil)) + + (setq buffer-undo-tree tree + buffer-undo-list (list nil 'undo-tree-canary))))) + + + +;; Versions of save/load functions for use in hooks +(defun undo-tree-save-history-from-hook () + (when (and undo-tree-mode undo-tree-auto-save-history + (not (eq buffer-undo-list t)) + buffer-file-name + (file-writable-p + (undo-tree-make-history-save-file-name buffer-file-name))) + (undo-tree-save-history nil 'overwrite) nil)) + +(define-obsolete-function-alias + 'undo-tree-save-history-hook 'undo-tree-save-history-from-hook + "`undo-tree-save-history-hook' is obsolete since undo-tree + version 0.6.6. Use `undo-tree-save-history-from-hook' instead.") + + +(defun undo-tree-load-history-from-hook () + (when (and undo-tree-mode undo-tree-auto-save-history + (not (eq buffer-undo-list t)) + (not revert-buffer-in-progress-p)) + (undo-tree-load-history nil 'noerror))) + +(define-obsolete-function-alias + 'undo-tree-load-history-hook 'undo-tree-load-history-from-hook + "`undo-tree-load-history-hook' is obsolete since undo-tree + version 0.6.6. Use `undo-tree-load-history-from-hook' instead.") + + +;; install history-auto-save hooks +(add-hook 'write-file-functions #'undo-tree-save-history-from-hook) +(add-hook 'kill-buffer-hook #'undo-tree-save-history-from-hook) +(add-hook 'find-file-hook #'undo-tree-load-history-from-hook) + + + + +;;; ===================================================================== +;;; Visualizer drawing functions + +(defun undo-tree-visualize () + "Visualize the current buffer's undo tree." + (interactive "*") + (unless undo-tree-mode + (user-error "Undo-tree mode not enabled in buffer")) + (deactivate-mark) + ;; throw error if undo is disabled in buffer + (when (eq buffer-undo-list t) + (user-error "No undo information in this buffer")) + ;; transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree' + (undo-list-transfer-to-tree) + ;; add hook to kill visualizer buffer if original buffer is changed + (add-hook 'before-change-functions 'undo-tree-kill-visualizer nil t) + ;; prepare *undo-tree* buffer, then draw tree in it + (let ((undo-tree buffer-undo-tree) + (buff (current-buffer)) + (display-buffer-mark-dedicated 'soft)) + (switch-to-buffer-other-window + (get-buffer-create undo-tree-visualizer-buffer-name)) + (setq undo-tree-visualizer-parent-buffer buff) + (setq undo-tree-visualizer-parent-mtime + (and (buffer-file-name buff) + (nth 5 (file-attributes (buffer-file-name buff))))) + (setq undo-tree-visualizer-initial-node (undo-tree-current undo-tree)) + (setq undo-tree-visualizer-spacing + (undo-tree-visualizer-calculate-spacing)) + (setq buffer-undo-tree undo-tree) + (undo-tree-visualizer-mode) + (setq buffer-undo-tree undo-tree) + (set (make-local-variable 'undo-tree-visualizer-lazy-drawing) + (or (eq undo-tree-visualizer-lazy-drawing t) + (and (numberp undo-tree-visualizer-lazy-drawing) + (>= (undo-tree-count undo-tree) + undo-tree-visualizer-lazy-drawing)))) + (when undo-tree-visualizer-diff (undo-tree-visualizer-show-diff)) + (let ((inhibit-read-only t)) (undo-tree-draw-tree undo-tree)))) + + +(defun undo-tree-kill-visualizer (&rest _dummy) + ;; Kill visualizer. Added to `before-change-functions' hook of original + ;; buffer when visualizer is invoked. + (unless (or undo-tree-inhibit-kill-visualizer + (null (get-buffer undo-tree-visualizer-buffer-name))) + (with-current-buffer undo-tree-visualizer-buffer-name + (undo-tree-visualizer-quit)))) + + + +(defun undo-tree-draw-tree (undo-tree) + ;; Draw undo-tree in current buffer starting from NODE (or root if nil). + (let ((inhibit-read-only t) + (node (if undo-tree-visualizer-lazy-drawing + (undo-tree-current undo-tree) + (undo-tree-root undo-tree)))) + (erase-buffer) + (setq undo-tree-visualizer-needs-extending-down nil + undo-tree-visualizer-needs-extending-up nil) + (undo-tree-clear-visualizer-data undo-tree) + (undo-tree-compute-widths node) + ;; lazy drawing starts vertically centred and displaced horizontally to + ;; the left (window-width/4), since trees will typically grow right + (if undo-tree-visualizer-lazy-drawing + (progn + (undo-tree-move-down (/ (window-height) 2)) + (undo-tree-move-forward (max 2 (/ (window-width) 4)))) ; left margin + ;; non-lazy drawing starts in centre at top of buffer + (undo-tree-move-down 1) ; top margin + (undo-tree-move-forward + (max (/ (window-width) 2) + (+ (undo-tree-node-char-lwidth node) + ;; add space for left part of left-most time-stamp + (if undo-tree-visualizer-timestamps + (/ (- undo-tree-visualizer-spacing 4) 2) + 0) + 2)))) ; left margin + ;; link starting node to its representation in visualizer + (setf (undo-tree-node-marker node) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker node) nil) + (move-marker (undo-tree-node-marker node) (point)) + ;; draw undo-tree + (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face) + node-list) + (if (not undo-tree-visualizer-lazy-drawing) + (undo-tree-extend-down node t) + (undo-tree-extend-down node) + (undo-tree-extend-up node) + (setq node-list undo-tree-visualizer-needs-extending-down + undo-tree-visualizer-needs-extending-down nil) + (while node-list (undo-tree-extend-down (pop node-list))))) + ;; highlight active branch + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) + (undo-tree-highlight-active-branch + (or undo-tree-visualizer-needs-extending-up + (undo-tree-root undo-tree)))) + ;; highlight current node + (undo-tree-draw-node (undo-tree-current undo-tree) 'current))) + + +(defun undo-tree-extend-down (node &optional bottom) + ;; Extend tree downwards starting from NODE and point. If BOTTOM is t, + ;; extend all the way down to the leaves. If BOTTOM is a node, extend down + ;; as far as that node. If BOTTOM is an integer, extend down as far as that + ;; line. Otherwise, only extend visible portion of tree. NODE is assumed to + ;; already have a node marker. Returns non-nil if anything was actually + ;; extended. + (let ((extended nil) + (cur-stack (list node)) + next-stack) + ;; don't bother extending if BOTTOM specifies an already-drawn node + (unless (and (undo-tree-node-p bottom) (undo-tree-node-marker bottom)) + ;; draw nodes layer by layer + (while (or cur-stack + (prog1 (setq cur-stack next-stack) + (setq next-stack nil))) + (setq node (pop cur-stack)) + ;; if node is within range being drawn... + (if (or (eq bottom t) + (and (undo-tree-node-p bottom) + (not (eq (undo-tree-node-previous node) bottom))) + (and (integerp bottom) + (>= bottom (line-number-at-pos + (undo-tree-node-marker node)))) + (and (null bottom) + (pos-visible-in-window-p (undo-tree-node-marker node) + nil t))) + ;; ...draw one layer of node's subtree (if not already drawn) + (progn + (unless (and (undo-tree-node-next node) + (undo-tree-node-marker + (nth (undo-tree-node-branch node) + (undo-tree-node-next node)))) + (goto-char (undo-tree-node-marker node)) + (undo-tree-draw-subtree node) + (setq extended t)) + (setq next-stack + (append (undo-tree-node-next node) next-stack))) + ;; ...otherwise, postpone drawing until later + (push node undo-tree-visualizer-needs-extending-down)))) + extended)) + + +(defun undo-tree-extend-up (node &optional top) + ;; Extend tree upwards starting from NODE. If TOP is t, extend all the way + ;; to root. If TOP is a node, extend up as far as that node. If TOP is an + ;; integer, extend up as far as that line. Otherwise, only extend visible + ;; portion of tree. NODE is assumed to already have a node marker. Returns + ;; non-nil if anything was actually extended. + (let ((extended nil) parent) + ;; don't bother extending if TOP specifies an already-drawn node + (unless (and (undo-tree-node-p top) (undo-tree-node-marker top)) + (while node + (setq parent (undo-tree-node-previous node)) + ;; if we haven't reached root... + (if parent + ;; ...and node is within range being drawn... + (if (or (eq top t) + (and (undo-tree-node-p top) (not (eq node top))) + (and (integerp top) + (< top (line-number-at-pos + (undo-tree-node-marker node)))) + (and (null top) + ;; NOTE: we check point in case window-start is outdated + (< (min (line-number-at-pos (point)) + (line-number-at-pos (window-start))) + (line-number-at-pos + (undo-tree-node-marker node))))) + ;; ...and it hasn't already been drawn + (when (not (undo-tree-node-marker parent)) + ;; link parent node to its representation in visualizer + (undo-tree-compute-widths parent) + (undo-tree-move-to-parent node) + (setf (undo-tree-node-marker parent) (make-marker)) + (set-marker-insertion-type + (undo-tree-node-marker parent) nil) + (move-marker (undo-tree-node-marker parent) (point)) + ;; draw subtree beneath parent + (setq undo-tree-visualizer-needs-extending-down + (nconc (delq node (undo-tree-draw-subtree parent)) + undo-tree-visualizer-needs-extending-down)) + (setq extended t)) + ;; ...otherwise, postpone drawing for later and exit + (setq undo-tree-visualizer-needs-extending-up (when parent node) + parent nil)) + + ;; if we've reached root, stop extending and add top margin + (setq undo-tree-visualizer-needs-extending-up nil) + (goto-char (undo-tree-node-marker node)) + (undo-tree-move-up 1) ; top margin + (delete-region (point-min) (line-beginning-position))) + ;; next iteration + (setq node parent))) + extended)) + + +(defun undo-tree-expand-down (from &optional to) + ;; Expand tree downwards. FROM is the node to start expanding from. Stop + ;; expanding at TO if specified. Otherwise, just expand visible portion of + ;; tree and highlight active branch from FROM. + (when undo-tree-visualizer-needs-extending-down + (let ((inhibit-read-only t) + node-list extended) + ;; extend down as far as TO node + (when to + (setq extended (undo-tree-extend-down from to)) + (goto-char (undo-tree-node-marker to)) + (redisplay t)) ; force redisplay to scroll buffer if necessary + ;; extend visible portion of tree downwards + (setq node-list undo-tree-visualizer-needs-extending-down + undo-tree-visualizer-needs-extending-down nil) + (when node-list + (dolist (n node-list) + (when (undo-tree-extend-down n) (setq extended t))) + ;; highlight active branch in newly-extended-down portion, if any + (when extended + (let ((undo-tree-insert-face + 'undo-tree-visualizer-active-branch-face)) + (undo-tree-highlight-active-branch from))))))) + + +(defun undo-tree-expand-up (from &optional to) + ;; Expand tree upwards. FROM is the node to start expanding from, TO is the + ;; node to stop expanding at. If TO node isn't specified, just expand visible + ;; portion of tree and highlight active branch down to FROM. + (when undo-tree-visualizer-needs-extending-up + (let ((inhibit-read-only t) + extended node-list) + ;; extend up as far as TO node + (when to + (setq extended (undo-tree-extend-up from to)) + (goto-char (undo-tree-node-marker to)) + ;; simulate auto-scrolling if close to top of buffer + (when (<= (line-number-at-pos (point)) scroll-margin) + (undo-tree-move-up (if (= scroll-conservatively 0) + (/ (window-height) 2) 3)) + (when (undo-tree-extend-up to) (setq extended t)) + (goto-char (undo-tree-node-marker to)) + (unless (= scroll-conservatively 0) (recenter scroll-margin)))) + ;; extend visible portion of tree upwards + (and undo-tree-visualizer-needs-extending-up + (undo-tree-extend-up undo-tree-visualizer-needs-extending-up) + (setq extended t)) + ;; extend visible portion of tree downwards + (setq node-list undo-tree-visualizer-needs-extending-down + undo-tree-visualizer-needs-extending-down nil) + (dolist (n node-list) (undo-tree-extend-down n)) + ;; highlight active branch in newly-extended-up portion, if any + (when extended + (let ((undo-tree-insert-face + 'undo-tree-visualizer-active-branch-face)) + (undo-tree-highlight-active-branch + (or undo-tree-visualizer-needs-extending-up + (undo-tree-root buffer-undo-tree)) + from)))))) + + + +(defun undo-tree-highlight-active-branch (node &optional end) + ;; Draw highlighted active branch below NODE in current buffer. Stop + ;; highlighting at END node if specified. + (let ((stack (list node))) + ;; draw active branch + (while stack + (setq node (pop stack)) + (unless (or (eq node end) + (memq node undo-tree-visualizer-needs-extending-down)) + (goto-char (undo-tree-node-marker node)) + (setq node (undo-tree-draw-subtree node 'active) + stack (nconc stack node)))))) + + +(defun undo-tree-draw-node (node &optional current) + ;; Draw symbol representing NODE in visualizer. If CURRENT is non-nil, node + ;; is current node. + (goto-char (undo-tree-node-marker node)) + (when undo-tree-visualizer-timestamps + (undo-tree-move-backward (/ undo-tree-visualizer-spacing 2))) + + (let* ((undo-tree-insert-face (and undo-tree-insert-face + (or (and (consp undo-tree-insert-face) + undo-tree-insert-face) + (list undo-tree-insert-face)))) + (register (undo-tree-node-register node)) + (unmodified (if undo-tree-visualizer-parent-mtime + (undo-tree-node-unmodified-p + node undo-tree-visualizer-parent-mtime) + (undo-tree-node-unmodified-p node))) + node-string) + ;; check node's register (if any) still stores appropriate undo-tree state + (unless (and register + (undo-tree-register-data-p + (registerv-data (get-register register))) + (eq node (undo-tree-register-data-node + (registerv-data (get-register register))))) + (setq register nil)) + ;; represent node by different symbols, depending on whether it's the + ;; current node, is saved in a register, or corresponds to an unmodified + ;; buffer + (setq node-string + (cond + (undo-tree-visualizer-timestamps + (undo-tree-timestamp-to-string + (undo-tree-node-timestamp node) + undo-tree-visualizer-relative-timestamps + current register)) + (register (char-to-string register)) + (unmodified "s") + (current "x") + (t "o")) + undo-tree-insert-face + (nconc + (cond + (current (list 'undo-tree-visualizer-current-face)) + (unmodified (list 'undo-tree-visualizer-unmodified-face)) + (register (list 'undo-tree-visualizer-register-face))) + undo-tree-insert-face)) + ;; draw node and link it to its representation in visualizer + (undo-tree-insert node-string) + (undo-tree-move-backward (if undo-tree-visualizer-timestamps + (1+ (/ undo-tree-visualizer-spacing 2)) + 1)) + (move-marker (undo-tree-node-marker node) (point)) + (put-text-property (point) (1+ (point)) 'undo-tree-node node))) + + +(defun undo-tree-draw-subtree (node &optional active-branch) + ;; Draw subtree rooted at NODE. The subtree will start from point. + ;; If ACTIVE-BRANCH is non-nil, just draw active branch below NODE. Returns + ;; list of nodes below NODE. + (let ((num-children (length (undo-tree-node-next node))) + node-list pos trunk-pos n) + ;; draw node itself + (undo-tree-draw-node node) + + (cond + ;; if we're at a leaf node, we're done + ((= num-children 0)) + + ;; if node has only one child, draw it (not strictly necessary to deal + ;; with this case separately, but as it's by far the most common case + ;; this makes the code clearer and more efficient) + ((= num-children 1) + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (undo-tree-move-backward 1) + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (undo-tree-move-backward 1) + (undo-tree-move-down 1) + (setq n (car (undo-tree-node-next node))) + ;; link next node to its representation in visualizer + (unless (markerp (undo-tree-node-marker n)) + (setf (undo-tree-node-marker n) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker n) nil)) + (move-marker (undo-tree-node-marker n) (point)) + ;; add next node to list of nodes to draw next + (push n node-list)) + + ;; if node has multiple children, draw branches + (t + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (undo-tree-move-backward 1) + (move-marker (setq trunk-pos (make-marker)) (point)) + ;; left subtrees + (undo-tree-move-backward + (- (undo-tree-node-char-lwidth node) + (undo-tree-node-char-lwidth + (car (undo-tree-node-next node))))) + (move-marker (setq pos (make-marker)) (point)) + (setq n (cons nil (undo-tree-node-next node))) + (dotimes (_ (/ num-children 2)) + (setq n (cdr n)) + (when (or (null active-branch) + (eq (car n) + (nth (undo-tree-node-branch node) + (undo-tree-node-next node)))) + (undo-tree-move-forward 2) + (undo-tree-insert ?_ (- trunk-pos pos 2)) + (goto-char pos) + (undo-tree-move-forward 1) + (undo-tree-move-down 1) + (undo-tree-insert ?/) + (undo-tree-move-backward 2) + (undo-tree-move-down 1) + ;; link node to its representation in visualizer + (unless (markerp (undo-tree-node-marker (car n))) + (setf (undo-tree-node-marker (car n)) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) + (move-marker (undo-tree-node-marker (car n)) (point)) + ;; add node to list of nodes to draw next + (push (car n) node-list)) + (goto-char pos) + (undo-tree-move-forward + (+ (undo-tree-node-char-rwidth (car n)) + (undo-tree-node-char-lwidth (cadr n)) + undo-tree-visualizer-spacing 1)) + (move-marker pos (point))) + ;; middle subtree (only when number of children is odd) + (when (= (mod num-children 2) 1) + (setq n (cdr n)) + (when (or (null active-branch) + (eq (car n) + (nth (undo-tree-node-branch node) + (undo-tree-node-next node)))) + (undo-tree-move-down 1) + (undo-tree-insert ?|) + (undo-tree-move-backward 1) + (undo-tree-move-down 1) + ;; link node to its representation in visualizer + (unless (markerp (undo-tree-node-marker (car n))) + (setf (undo-tree-node-marker (car n)) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) + (move-marker (undo-tree-node-marker (car n)) (point)) + ;; add node to list of nodes to draw next + (push (car n) node-list)) + (goto-char pos) + (undo-tree-move-forward + (+ (undo-tree-node-char-rwidth (car n)) + (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0) + undo-tree-visualizer-spacing 1)) + (move-marker pos (point))) + ;; right subtrees + (move-marker trunk-pos (1+ trunk-pos)) + (dotimes (_ (/ num-children 2)) + (setq n (cdr n)) + (when (or (null active-branch) + (eq (car n) + (nth (undo-tree-node-branch node) + (undo-tree-node-next node)))) + (goto-char trunk-pos) + (undo-tree-insert ?_ (- pos trunk-pos 1)) + (goto-char pos) + (undo-tree-move-backward 1) + (undo-tree-move-down 1) + (undo-tree-insert ?\\) + (undo-tree-move-down 1) + ;; link node to its representation in visualizer + (unless (markerp (undo-tree-node-marker (car n))) + (setf (undo-tree-node-marker (car n)) (make-marker)) + (set-marker-insertion-type (undo-tree-node-marker (car n)) nil)) + (move-marker (undo-tree-node-marker (car n)) (point)) + ;; add node to list of nodes to draw next + (push (car n) node-list)) + (when (cdr n) + (goto-char pos) + (undo-tree-move-forward + (+ (undo-tree-node-char-rwidth (car n)) + (if (cadr n) (undo-tree-node-char-lwidth (cadr n)) 0) + undo-tree-visualizer-spacing 1)) + (move-marker pos (point)))) + )) + ;; return list of nodes to draw next + (nreverse node-list))) + + +(defun undo-tree-node-char-lwidth (node) + ;; Return left-width of NODE measured in characters. + (if (= (length (undo-tree-node-next node)) 0) 0 + (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-lwidth node)) + (if (= (undo-tree-node-cwidth node) 0) + (1+ (/ undo-tree-visualizer-spacing 2)) 0)))) + + +(defun undo-tree-node-char-rwidth (node) + ;; Return right-width of NODE measured in characters. + (if (= (length (undo-tree-node-next node)) 0) 0 + (- (* (+ undo-tree-visualizer-spacing 1) (undo-tree-node-rwidth node)) + (if (= (undo-tree-node-cwidth node) 0) + (1+ (/ undo-tree-visualizer-spacing 2)) 0)))) + + +(defun undo-tree-insert (str &optional arg) + ;; Insert character or string STR ARG times, overwriting, and using + ;; `undo-tree-insert-face'. + (unless arg (setq arg 1)) + (when (characterp str) + (setq str (make-string arg str)) + (setq arg 1)) + (dotimes (_ arg) (insert str)) + (setq arg (* arg (length str))) + (undo-tree-move-forward arg) + ;; make sure mark isn't active, otherwise `backward-delete-char' might + ;; delete region instead of single char if transient-mark-mode is enabled + (setq mark-active nil) + (backward-delete-char arg) + (when undo-tree-insert-face + (put-text-property (- (point) arg) (point) 'face undo-tree-insert-face))) + + +(defun undo-tree-move-down (&optional arg) + ;; Move down, extending buffer if necessary. + (let ((row (line-number-at-pos)) + (col (current-column)) + line) + (unless arg (setq arg 1)) + (forward-line arg) + (setq line (line-number-at-pos)) + ;; if buffer doesn't have enough lines, add some + (when (/= line (+ row arg)) + (cond + ((< arg 0) + (insert (make-string (- line row arg) ?\n)) + (forward-line (+ arg (- row line)))) + (t (insert (make-string (- arg (- line row)) ?\n))))) + (undo-tree-move-forward col))) + + +(defun undo-tree-move-up (&optional arg) + ;; Move up, extending buffer if necessary. + (unless arg (setq arg 1)) + (undo-tree-move-down (- arg))) + + +(defun undo-tree-move-forward (&optional arg) + ;; Move forward, extending buffer if necessary. + (unless arg (setq arg 1)) + (let (n) + (cond + ((>= arg 0) + (setq n (- (line-end-position) (point))) + (if (> n arg) + (forward-char arg) + (end-of-line) + (insert (make-string (- arg n) ? )))) + ((< arg 0) + (setq arg (- arg)) + (setq n (- (point) (line-beginning-position))) + (when (< (- n 2) arg) ; -2 to create left-margin + ;; no space left - shift entire buffer contents right! + (let ((pos (move-marker (make-marker) (point)))) + (set-marker-insertion-type pos t) + (goto-char (point-min)) + (while (not (eobp)) + (insert-before-markers (make-string (- arg -2 n) ? )) + (forward-line 1)) + (goto-char pos))) + (backward-char arg))))) + + +(defun undo-tree-move-backward (&optional arg) + ;; Move backward, extending buffer if necessary. + (unless arg (setq arg 1)) + (undo-tree-move-forward (- arg))) + + +(defun undo-tree-move-to-parent (node) + ;; Move to position of parent of NODE, extending buffer if necessary. + (let* ((parent (undo-tree-node-previous node)) + (n (undo-tree-node-next parent)) + (l (length n)) p) + (goto-char (undo-tree-node-marker node)) + (unless (= l 1) + ;; move horizontally + (setq p (undo-tree-position node n)) + (cond + ;; node in centre subtree: no horizontal movement + ((and (= (mod l 2) 1) (= p (/ l 2)))) + ;; node in left subtree: move right + ((< p (/ l 2)) + (setq n (nthcdr p n)) + (undo-tree-move-forward + (+ (undo-tree-node-char-rwidth (car n)) + (/ undo-tree-visualizer-spacing 2) 1)) + (dotimes (_ (- (/ l 2) p 1)) + (setq n (cdr n)) + (undo-tree-move-forward + (+ (undo-tree-node-char-lwidth (car n)) + (undo-tree-node-char-rwidth (car n)) + undo-tree-visualizer-spacing 1))) + (when (= (mod l 2) 1) + (setq n (cdr n)) + (undo-tree-move-forward + (+ (undo-tree-node-char-lwidth (car n)) + (/ undo-tree-visualizer-spacing 2) 1)))) + (t ;; node in right subtree: move left + (setq n (nthcdr (/ l 2) n)) + (when (= (mod l 2) 1) + (undo-tree-move-backward + (+ (undo-tree-node-char-rwidth (car n)) + (/ undo-tree-visualizer-spacing 2) 1)) + (setq n (cdr n))) + (dotimes (_ (- p (/ l 2) (mod l 2))) + (undo-tree-move-backward + (+ (undo-tree-node-char-lwidth (car n)) + (undo-tree-node-char-rwidth (car n)) + undo-tree-visualizer-spacing 1)) + (setq n (cdr n))) + (undo-tree-move-backward + (+ (undo-tree-node-char-lwidth (car n)) + (/ undo-tree-visualizer-spacing 2) 1))))) + ;; move vertically + (undo-tree-move-up 3))) + + +(defun undo-tree-timestamp-to-string + (timestamp &optional relative current register) + ;; Convert TIMESTAMP to string (either absolute or RELATVE time), indicating + ;; if it's the CURRENT node and/or has an associated REGISTER. + (if relative + ;; relative time + (let ((time (floor (float-time + (time-subtract (current-time) timestamp)))) + n) + (setq time + ;; years + (if (> (setq n (/ time 315360000)) 0) + (if (> n 999) "-ages" (format "-%dy" n)) + (setq time (% time 315360000)) + ;; days + (if (> (setq n (/ time 86400)) 0) + (format "-%dd" n) + (setq time (% time 86400)) + ;; hours + (if (> (setq n (/ time 3600)) 0) + (format "-%dh" n) + (setq time (% time 3600)) + ;; mins + (if (> (setq n (/ time 60)) 0) + (format "-%dm" n) + ;; secs + (format "-%ds" (% time 60))))))) + (setq time (concat + (if current "*" " ") + time + (if register (concat "[" (char-to-string register) "]") + " "))) + (setq n (length time)) + (if (< n 9) + (concat (make-string (- 9 n) ? ) time) + time)) + ;; absolute time + (concat (if current " *" " ") + (format-time-string "%H:%M:%S" timestamp) + (if register + (concat "[" (char-to-string register) "]") + " ")))) + + + + +;;; ===================================================================== +;;; Visualizer modes + +(define-derived-mode + undo-tree-visualizer-mode special-mode "undo-tree-visualizer" + "Major mode used in undo-tree visualizer. + +The undo-tree visualizer can only be invoked from a buffer in +which `undo-tree-mode' is enabled. The visualizer displays the +undo history tree graphically, and allows you to browse around +the undo history, undoing or redoing the corresponding changes in +the parent buffer. + +Within the undo-tree visualizer, the following keys are available: + + \\{undo-tree-visualizer-mode-map}" + :syntax-table nil + :abbrev-table nil + (setq truncate-lines t) + (setq cursor-type nil) + (setq undo-tree-visualizer-selected-node nil) + (make-local-variable 'undo-tree-visualizer-timestamps) + (make-local-variable 'undo-tree-visualizer-diff)) + + +(define-minor-mode undo-tree-visualizer-selection-mode + "Toggle mode to select nodes in undo-tree visualizer." + :lighter "Select" + :keymap undo-tree-visualizer-selection-mode-map + :group undo-tree + (cond + ;; enable selection mode + (undo-tree-visualizer-selection-mode + (setq cursor-type 'box) + (setq undo-tree-visualizer-selected-node + (undo-tree-current buffer-undo-tree)) + ;; erase diff (if any), as initially selected node is identical to current + (when undo-tree-visualizer-diff + (let ((buff (get-buffer undo-tree-diff-buffer-name)) + (inhibit-read-only t)) + (when buff (with-current-buffer buff (erase-buffer)))))) + (t ;; disable selection mode + (setq cursor-type nil) + (setq undo-tree-visualizer-selected-node nil) + (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) + (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff))) + )) + + + + +;;; ===================================================================== +;;; Visualizer commands + +(defun undo-tree-visualize-undo (&optional arg) + "Undo changes. A numeric ARG serves as a repeat count." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((old (undo-tree-current buffer-undo-tree)) + current) + ;; undo in parent buffer + (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer) + (deactivate-mark) + (unwind-protect + (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-undo-1 arg)) + (setq current (undo-tree-current buffer-undo-tree)) + (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) + ;; unhighlight old current node + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face) + (inhibit-read-only t)) + (undo-tree-draw-node old)) + ;; when using lazy drawing, extend tree upwards as required + (when undo-tree-visualizer-lazy-drawing + (undo-tree-expand-up old current)) + ;; highlight new current node + (let ((inhibit-read-only t)) (undo-tree-draw-node current 'current)) + ;; update diff display, if any + (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff))))) + + +(defun undo-tree-visualize-redo (&optional arg) + "Redo changes. A numeric ARG serves as a repeat count." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((old (undo-tree-current buffer-undo-tree)) + current) + ;; redo in parent buffer + (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer) + (deactivate-mark) + (unwind-protect + (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-redo-1 arg)) + (setq current (undo-tree-current buffer-undo-tree)) + (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) + ;; unhighlight old current node + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face) + (inhibit-read-only t)) + (undo-tree-draw-node old)) + ;; when using lazy drawing, extend tree downwards as required + (when undo-tree-visualizer-lazy-drawing + (undo-tree-expand-down old current)) + ;; highlight new current node + (let ((inhibit-read-only t)) (undo-tree-draw-node current 'current)) + ;; update diff display, if any + (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff))))) + + +(defun undo-tree-visualize-switch-branch-right (arg) + "Switch to next branch of the undo tree. +This will affect which branch to descend when *redoing* changes +using `undo-tree-redo' or `undo-tree-visualizer-redo'." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + ;; un-highlight old active branch below current node + (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) + (let ((undo-tree-insert-face 'undo-tree-visualizer-default-face) + (inhibit-read-only t)) + (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree))) + ;; increment branch + (let ((branch (undo-tree-node-branch (undo-tree-current buffer-undo-tree)))) + (setf (undo-tree-node-branch (undo-tree-current buffer-undo-tree)) + (cond + ((>= (+ branch arg) (undo-tree-num-branches)) + (1- (undo-tree-num-branches))) + ((<= (+ branch arg) 0) 0) + (t (+ branch arg)))) + (let ((inhibit-read-only t)) + ;; highlight new active branch below current node + (goto-char (undo-tree-node-marker (undo-tree-current buffer-undo-tree))) + (let ((undo-tree-insert-face 'undo-tree-visualizer-active-branch-face)) + (undo-tree-highlight-active-branch (undo-tree-current buffer-undo-tree))) + ;; re-highlight current node + (undo-tree-draw-node (undo-tree-current buffer-undo-tree) 'current)))) + + +(defun undo-tree-visualize-switch-branch-left (arg) + "Switch to previous branch of the undo tree. +This will affect which branch to descend when *redoing* changes +using `undo-tree-redo' or `undo-tree-visualizer-redo'." + (interactive "p") + (undo-tree-visualize-switch-branch-right (- arg))) + + +(defun undo-tree-visualizer-quit () + "Quit the undo-tree visualizer." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (undo-tree-clear-visualizer-data buffer-undo-tree) + ;; remove kill visualizer hook from parent buffer + (unwind-protect + (with-current-buffer undo-tree-visualizer-parent-buffer + (remove-hook 'before-change-functions 'undo-tree-kill-visualizer t)) + ;; kill diff buffer, if any + (when undo-tree-visualizer-diff (undo-tree-visualizer-hide-diff)) + (let ((parent undo-tree-visualizer-parent-buffer) + window) + ;; kill visualizer buffer + (kill-buffer nil) + ;; switch back to parent buffer + (unwind-protect + (if (setq window (get-buffer-window parent)) + (select-window window) + (switch-to-buffer parent)))))) + + +(defun undo-tree-visualizer-abort () + "Quit the undo-tree visualizer and return buffer to original state." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((node undo-tree-visualizer-initial-node)) + (undo-tree-visualizer-quit) + (undo-tree-set node))) + + +(defun undo-tree-visualizer-set (&optional pos) + "Set buffer to state corresponding to undo tree node +at POS, or point if POS is nil." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (unless pos (setq pos (point))) + (let ((node (get-text-property pos 'undo-tree-node))) + (when node + ;; set parent buffer to state corresponding to node at POS + (switch-to-buffer-other-window undo-tree-visualizer-parent-buffer) + (let ((undo-tree-inhibit-kill-visualizer t)) (undo-tree-set node)) + (switch-to-buffer-other-window undo-tree-visualizer-buffer-name) + ;; re-draw undo tree + (let ((inhibit-read-only t)) (undo-tree-draw-tree buffer-undo-tree)) + (when undo-tree-visualizer-diff (undo-tree-visualizer-update-diff))))) + + +(defun undo-tree-visualizer-mouse-set (pos) + "Set buffer to state corresponding to undo tree node +at mouse event POS." + (interactive "@e") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (undo-tree-visualizer-set (event-start (nth 1 pos)))) + + +(defun undo-tree-visualize-undo-to-x (&optional x) + "Undo to last branch point, register, or saved state. +If X is the symbol `branch', undo to last branch point. If X is +the symbol `register', undo to last register. If X is the symbol +`saved', undo to last saved state. If X is null, undo to first of +these that's encountered. + +Interactively, a single \\[universal-argument] specifies +`branch', a double \\[universal-argument] \\[universal-argument] +specifies `saved', and a negative prefix argument specifies +`register'." + (interactive "P") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (when (and (called-interactively-p 'any) x) + (setq x (prefix-numeric-value x) + x (cond + ((< x 0) 'register) + ((<= x 4) 'branch) + (t 'saved)))) + (let ((current (if undo-tree-visualizer-selection-mode + undo-tree-visualizer-selected-node + (undo-tree-current buffer-undo-tree))) + (diff undo-tree-visualizer-diff) + r) + (undo-tree-visualizer-hide-diff) + (while (and (undo-tree-node-previous current) + (or (if undo-tree-visualizer-selection-mode + (progn + (undo-tree-visualizer-select-previous) + (setq current undo-tree-visualizer-selected-node)) + (undo-tree-visualize-undo) + (setq current (undo-tree-current buffer-undo-tree))) + t) + ;; branch point + (not (or (and (or (null x) (eq x 'branch)) + (> (undo-tree-num-branches) 1)) + ;; register + (and (or (null x) (eq x 'register)) + (setq r (undo-tree-node-register current)) + (undo-tree-register-data-p + (setq r (registerv-data (get-register r)))) + (eq current (undo-tree-register-data-node r))) + ;; saved state + (and (or (null x) (eq x 'saved)) + (undo-tree-node-unmodified-p current)) + )))) + ;; update diff display, if any + (when diff + (undo-tree-visualizer-show-diff + (when undo-tree-visualizer-selection-mode + undo-tree-visualizer-selected-node))))) + + +(defun undo-tree-visualize-redo-to-x (&optional x) + "Redo to last branch point, register, or saved state. +If X is the symbol `branch', redo to last branch point. If X is +the symbol `register', redo to last register. If X is the sumbol +`saved', redo to last saved state. If X is null, redo to first of +these that's encountered. + +Interactively, a single \\[universal-argument] specifies +`branch', a double \\[universal-argument] \\[universal-argument] +specifies `saved', and a negative prefix argument specifies +`register'." + (interactive "P") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (when (and (called-interactively-p 'any) x) + (setq x (prefix-numeric-value x) + x (cond + ((< x 0) 'register) + ((<= x 4) 'branch) + (t 'saved)))) + (let ((current (if undo-tree-visualizer-selection-mode + undo-tree-visualizer-selected-node + (undo-tree-current buffer-undo-tree))) + (diff undo-tree-visualizer-diff) + r) + (undo-tree-visualizer-hide-diff) + (while (and (undo-tree-node-next current) + (or (if undo-tree-visualizer-selection-mode + (progn + (undo-tree-visualizer-select-next) + (setq current undo-tree-visualizer-selected-node)) + (undo-tree-visualize-redo) + (setq current (undo-tree-current buffer-undo-tree))) + t) + ;; branch point + (not (or (and (or (null x) (eq x 'branch)) + (> (undo-tree-num-branches) 1)) + ;; register + (and (or (null x) (eq x 'register)) + (setq r (undo-tree-node-register current)) + (undo-tree-register-data-p + (setq r (registerv-data (get-register r)))) + (eq current (undo-tree-register-data-node r))) + ;; saved state + (and (or (null x) (eq x 'saved)) + (undo-tree-node-unmodified-p current)) + )))) + ;; update diff display, if any + (when diff + (undo-tree-visualizer-show-diff + (when undo-tree-visualizer-selection-mode + undo-tree-visualizer-selected-node))))) + + +(defun undo-tree-visualizer-toggle-timestamps () + "Toggle display of time-stamps." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (setq undo-tree-visualizer-timestamps (not undo-tree-visualizer-timestamps)) + (setq undo-tree-visualizer-spacing (undo-tree-visualizer-calculate-spacing)) + ;; redraw tree + (let ((inhibit-read-only t)) (undo-tree-draw-tree buffer-undo-tree))) + + +(defun undo-tree-visualizer-scroll-left (&optional arg) + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (scroll-left (or arg 1) t)) + + +(defun undo-tree-visualizer-scroll-right (&optional arg) + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (scroll-right (or arg 1) t)) + + +(defun undo-tree-visualizer-scroll-up (&optional arg) + (interactive "P") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (if (or (and (numberp arg) (< arg 0)) (eq arg '-)) + (undo-tree-visualizer-scroll-down arg) + ;; scroll up and expand newly-visible portion of tree + (unwind-protect + (scroll-up-command arg) + (undo-tree-expand-down + (nth (undo-tree-node-branch (undo-tree-current buffer-undo-tree)) + (undo-tree-node-next (undo-tree-current buffer-undo-tree))))) + ;; signal error if at eob + (when (and (not undo-tree-visualizer-needs-extending-down) (eobp)) + (scroll-up)))) + + +(defun undo-tree-visualizer-scroll-down (&optional arg) + (interactive "P") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (if (or (and (numberp arg) (< arg 0)) (eq arg '-)) + (undo-tree-visualizer-scroll-up arg) + ;; ensure there's enough room at top of buffer to scroll + (let ((scroll-lines + (or arg (- (window-height) next-screen-context-lines))) + (window-line (1- (line-number-at-pos (window-start))))) + (when (and undo-tree-visualizer-needs-extending-up + (< window-line scroll-lines)) + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (undo-tree-move-up (- scroll-lines window-line))))) + ;; scroll down and expand newly-visible portion of tree + (unwind-protect + (scroll-down-command arg) + (undo-tree-expand-up + (undo-tree-node-previous (undo-tree-current buffer-undo-tree)))) + ;; signal error if at bob + (when (and (not undo-tree-visualizer-needs-extending-down) (bobp)) + (scroll-down)))) + + + + +;;; ===================================================================== +;;; Visualizer selection mode commands + +(defun undo-tree-visualizer-select-previous (&optional arg) + "Move to previous node." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((node undo-tree-visualizer-selected-node)) + (catch 'top + (dotimes (_ (or arg 1)) + (unless (undo-tree-node-previous node) (throw 'top t)) + (setq node (undo-tree-node-previous node)))) + ;; when using lazy drawing, extend tree upwards as required + (when undo-tree-visualizer-lazy-drawing + (undo-tree-expand-up undo-tree-visualizer-selected-node node)) + ;; update diff display, if any + (when (and undo-tree-visualizer-diff + (not (eq node undo-tree-visualizer-selected-node))) + (undo-tree-visualizer-update-diff node)) + ;; move to selected node + (goto-char (undo-tree-node-marker node)) + (setq undo-tree-visualizer-selected-node node))) + + +(defun undo-tree-visualizer-select-next (&optional arg) + "Move to next node." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((node undo-tree-visualizer-selected-node)) + (catch 'bottom + (dotimes (_ (or arg 1)) + (unless (nth (undo-tree-node-branch node) (undo-tree-node-next node)) + (throw 'bottom t)) + (setq node + (nth (undo-tree-node-branch node) (undo-tree-node-next node))))) + ;; when using lazy drawing, extend tree downwards as required + (when undo-tree-visualizer-lazy-drawing + (undo-tree-expand-down undo-tree-visualizer-selected-node node)) + ;; update diff display, if any + (when (and undo-tree-visualizer-diff + (not (eq node undo-tree-visualizer-selected-node))) + (undo-tree-visualizer-update-diff node)) + ;; move to selected node + (goto-char (undo-tree-node-marker node)) + (setq undo-tree-visualizer-selected-node node))) + + +(defun undo-tree-visualizer-select-right (&optional arg) + "Move right to a sibling node." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((node undo-tree-visualizer-selected-node) + end) + (goto-char (undo-tree-node-marker undo-tree-visualizer-selected-node)) + (setq end (line-end-position)) + (catch 'end + (dotimes (_ arg) + (while (or (null node) (eq node undo-tree-visualizer-selected-node)) + (forward-char) + (setq node (get-text-property (point) 'undo-tree-node)) + (when (= (point) end) (throw 'end t))))) + (goto-char (undo-tree-node-marker + (or node undo-tree-visualizer-selected-node))) + (when (and undo-tree-visualizer-diff node + (not (eq node undo-tree-visualizer-selected-node))) + (undo-tree-visualizer-update-diff node)) + (when node (setq undo-tree-visualizer-selected-node node)))) + + +(defun undo-tree-visualizer-select-left (&optional arg) + "Move left to a sibling node." + (interactive "p") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (let ((node (get-text-property (point) 'undo-tree-node)) + beg) + (goto-char (undo-tree-node-marker undo-tree-visualizer-selected-node)) + (setq beg (line-beginning-position)) + (catch 'beg + (dotimes (_ arg) + (while (or (null node) (eq node undo-tree-visualizer-selected-node)) + (backward-char) + (setq node (get-text-property (point) 'undo-tree-node)) + (when (= (point) beg) (throw 'beg t))))) + (goto-char (undo-tree-node-marker + (or node undo-tree-visualizer-selected-node))) + (when (and undo-tree-visualizer-diff node + (not (eq node undo-tree-visualizer-selected-node))) + (undo-tree-visualizer-update-diff node)) + (when node (setq undo-tree-visualizer-selected-node node)))) + + +(defun undo-tree-visualizer-select (pos) + (let ((node (get-text-property pos 'undo-tree-node))) + (when node + ;; select node at POS + (goto-char (undo-tree-node-marker node)) + ;; when using lazy drawing, extend tree up and down as required + (when undo-tree-visualizer-lazy-drawing + (undo-tree-expand-up undo-tree-visualizer-selected-node node) + (undo-tree-expand-down undo-tree-visualizer-selected-node node)) + ;; update diff display, if any + (when (and undo-tree-visualizer-diff + (not (eq node undo-tree-visualizer-selected-node))) + (undo-tree-visualizer-update-diff node)) + ;; update selected node + (setq undo-tree-visualizer-selected-node node) + ))) + + +(defun undo-tree-visualizer-mouse-select (pos) + "Select undo tree node at mouse event POS." + (interactive "@e") + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (undo-tree-visualizer-select (event-start (nth 1 pos)))) + + + + +;;; ===================================================================== +;;; Visualizer diff display + +(defun undo-tree-visualizer-toggle-diff () + "Toggle diff display in undo-tree visualizer." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (if undo-tree-visualizer-diff + (undo-tree-visualizer-hide-diff) + (undo-tree-visualizer-show-diff))) + + +(defun undo-tree-visualizer-selection-toggle-diff () + "Toggle diff display in undo-tree visualizer selection mode." + (interactive) + (unless (eq major-mode 'undo-tree-visualizer-mode) + (user-error "Undo-tree mode not enabled in buffer")) + (if undo-tree-visualizer-diff + (undo-tree-visualizer-hide-diff) + (let ((node (get-text-property (point) 'undo-tree-node))) + (when node (undo-tree-visualizer-show-diff node))))) + + +(defun undo-tree-visualizer-show-diff (&optional node) + ;; show visualizer diff display + (setq undo-tree-visualizer-diff t) + (let ((buff (with-current-buffer undo-tree-visualizer-parent-buffer + (undo-tree-diff node))) + (display-buffer-mark-dedicated 'soft) + win) + (setq win (split-window)) + (set-window-buffer win buff) + (shrink-window-if-larger-than-buffer win))) + + +(defun undo-tree-visualizer-hide-diff () + ;; hide visualizer diff display + (setq undo-tree-visualizer-diff nil) + (let ((win (get-buffer-window undo-tree-diff-buffer-name))) + (when win (with-selected-window win (kill-buffer-and-window))))) + + +(defun undo-tree-diff (&optional node) + ;; Create diff between NODE and current state (or previous state and current + ;; state, if NODE is null). Returns buffer containing diff. + (let (tmpfile buff) + ;; generate diff + (let ((undo-tree-inhibit-kill-visualizer t) + (current (undo-tree-current buffer-undo-tree))) + (undo-tree-set (or node (undo-tree-node-previous current) current) + 'preserve-timestamps) + (setq tmpfile (diff-file-local-copy (current-buffer))) + (undo-tree-set current 'preserve-timestamps)) + (setq buff (diff-no-select + tmpfile (current-buffer) nil 'noasync + (get-buffer-create undo-tree-diff-buffer-name))) + ;; delete process messages and useless headers from diff buffer + (let ((inhibit-read-only t)) + (with-current-buffer buff + (goto-char (point-min)) + (delete-region (point) (1+ (line-end-position 3))) + (goto-char (point-max)) + (forward-line -2) + (delete-region (point) (point-max)) + (setq cursor-type nil) + (setq buffer-read-only t))) + buff)) + + +(defun undo-tree-visualizer-update-diff (&optional node) + ;; update visualizer diff display to show diff between current state and + ;; NODE (or previous state, if NODE is null) + (with-current-buffer undo-tree-visualizer-parent-buffer + (undo-tree-diff node)) + (let ((win (get-buffer-window undo-tree-diff-buffer-name))) + (when win + (balance-windows) + (shrink-window-if-larger-than-buffer win)))) + + + +(provide 'undo-tree) + +;;; undo-tree.el ends here diff --git a/.emacs.d/logo.jpg b/.emacs.d/logo.jpg new file mode 100644 index 0000000..35bfa97 Binary files /dev/null and b/.emacs.d/logo.jpg differ diff --git a/.emacs.d/themes/bedroom-theme.el b/.emacs.d/themes/bedroom-theme.el new file mode 100644 index 0000000..20f3656 --- /dev/null +++ b/.emacs.d/themes/bedroom-theme.el @@ -0,0 +1,41 @@ +;;; bedroom-theme.el --- Max's dark color theme -*- lexical-binding: t; -*- + +;;; Commentary: +;; A dark color theme based on Max's personal color settings. + +;;; Code: + +(deftheme bedroom + "Max's dark color theme.") + +(custom-theme-set-faces + 'bedroom + ;; Basic faces + '(default ((t (:foreground "#DADEE5" :background "#141B2B")))) + '(cursor ((t (:background "#FF69B4")))) + '(region ((t (:background "#15285A")))) + '(hl-line ((t (:background "#000000")))) + '(highlight ((t (:background "#15285A")))) + '(mode-line ((t (:background "#d3b58d" :foreground "#141B2B")))) + '(mode-line-inactive ((t (:inverse-video t)))) + + ;; Font lock faces + '(font-lock-builtin-face ((t (:foreground "#DADEE5")))) + '(font-lock-comment-face ((t (:foreground "#87919D")))) + '(font-lock-string-face ((t (:foreground "#d3b58d")))) + '(font-lock-keyword-face ((t (:foreground "#c47616")))) + '(font-lock-function-name-face ((t (:foreground "#DADEE5")))) + '(font-lock-variable-name-face ((t (:foreground "#DADEE5")))) + '(font-lock-constant-face ((t (:foreground "#BBABC3")))) + '(font-lock-type-face ((t (:foreground "#85B8DE")))) + '(font-lock-warning-face ((t (:foreground "#FC2D07")))) + + ;; Custom/widget faces + '(custom-group-tag ((t (:underline t :foreground "lightblue")))) + '(custom-variable-tag ((t (:underline t :foreground "lightblue")))) + '(widget-field ((t (:foreground "white")))) + '(widget-single-line-field ((t (:background "darkgray"))))) + +(provide-theme 'bedroom) + +;;; bedroom-theme.el ends here diff --git a/.emacs.d/themes/fleury-theme.el b/.emacs.d/themes/fleury-theme.el new file mode 100644 index 0000000..f6a7b31 --- /dev/null +++ b/.emacs.d/themes/fleury-theme.el @@ -0,0 +1,129 @@ +;;; fleury-theme.el --- The fleury color theme + +;; Copyright (C) 2025 Shams Parvez Arka +;; See end of file for extended copyright information + +;; Author : Shams Parvez Arka +;; URL : https://github.com/ShamsParvezArka/fleury-theme.el +;; Version : 0.5 +;; Commentary: "Coming up with an original idea in 21st century +;; is tough, even my dreams aren't original anymore!" + + +(deftheme fleury "The fleury color theme") + +;; Color palette +(let ((rich-black "#020202") + (light-bronze "#b99468") + (charcoal-gray "#212121") + (charcoal-gray-lite "#1e1e1e") + (gunmetal-blue "#303040") + (dark-slate "#222425") + (amber-gold "#fcaa05") + (medium-gray "#404040") + (jet-black "#121212") + (dim-gray "#666666") + (goldenrod "#f0c674") + (bright-orange "#ffaa00") + (dusty-rose "#dc7575") + (sunflower-yellow "#edb211") + (burnt-orange "#de451f") + (sky-blue "#2895c7") + (sky-blue-lite "#2f2f38") + (bright-red "#ff0000") + (fresh-green "#66bc11") + (lime-green "#003939") + (vivid-vermilion "#f0500c") + (golden-yellow "#f0bb0c") + (pure-black "#000000") + (aqua-ice "#8ffff2") + (dusty-sage "#9ba290") + (coffee-brown "#63523d") + + (mode-line-foreground-active "#e7aa4d") + (mode-line-background-active "#1a120b") + (mode-line-border "#161616") + ) + + (custom-theme-set-faces + 'fleury + + ;; UI Elements + `(default ((t (:background ,rich-black :foreground ,light-bronze)))) + `(cursor ((t (:background ,fresh-green)))) + `(region ((t (:background ,lime-green)))) + `(highlight ((t (:background ,charcoal-gray-lite)))) + `(fringe ((t (:background ,dark-slate)))) + `(vertical-border ((t (:foreground ,dark-slate)))) + `(minibuffer-prompt ((t (:foreground ,amber-gold :weight bold)))) + + ;; Line Numbers + `(line-number ((t (:foreground ,medium-gray :background ,rich-black)))) + `(line-number-current-line ((t (:background ,charcoal-gray-lite :foreground ,light-bronze)))) + + ;; Font Lock Faces + `(font-lock-comment-face ((t (:foreground ,dim-gray)))) + `(font-lock-keyword-face ((t (:foreground ,goldenrod)))) + `(font-lock-string-face ((t (:foreground ,bright-orange)))) + `(font-lock-constant-face ((t (:foreground ,bright-orange)))) + `(font-lock-builtin-face ((t (:foreground ,dusty-rose)))) + `(font-lock-preprocessor-face ((t (:foreground,dusty-rose)))) + `(font-lock-type-face ((t (:foreground ,sunflower-yellow)))) + `(font-lock-function-name-face ((t (:foreground ,burnt-orange)))) + `(font-lock-variable-name-face ((t (:foreground ,light-bronze)))) + `(font-lock-variable-use-face ((t (:foreground ,sky-blue)))) + `(font-lock-preprocessor-face ((t (:foreground ,dusty-rose)))) + `(font-lock-warning-face ((t (:foreground ,bright-red :weight bold)))) + `(font-lock-doc-face ((t (:foreground ,fresh-green)))) + + ;; Mode Line + `(mode-line ((t (:background ,mode-line-background-active :foreground ,mode-line-foreground-active :box (:line-width 1 :color ,mode-line-border :style nil))))) + `(mode-line-inactive ((t (:background ,rich-black :foreground ,mode-line-foreground-active :box (:line-width 1 :color ,mode-line-border :style nil))))) + + ;; Search & String Matching + `(match ((t (:background ,golden-yellow :foreground ,pure-black)))) + `(isearch ((t (:background ,vivid-vermilion :foreground ,pure-black)))) + `(lazy-highlight ((t (:background ,golden-yellow :foreground ,pure-black)))) + `(ido-first-match ((t (:foreground ,golden-yellow)))) + `(ido-only-match ((t (:foreground ,vivid-vermilion)))) + + ;; Custom Elements + `(show-paren-match ((t (:background ,sky-blue-lite)))) + `(show-paren-mismatch ((t (:background ,dusty-sage)))) + + ;; Tooltip and Popup + `(tooltip ((t (:background ,coffee-brown :foreground ,amber-gold)))) + + ;; Compilation + `(flycheck-error ((t (:underline (:color ,bright-red :style wave))))) + `(compilation-error ((t (:foreground ,bright-red)))) + `(compilation-info ((t ,(list :foreground fresh-green :inherit 'unspecified)))) + `(compilation-warning ((t ,(list :foreground coffee-brown :bold t :inherit 'unspecified)))) + `(compilation-mode-line-fail ((t ,(list :foreground bright-red :weight 'bold :inherit 'unspecified)))) + `(compilation-mode-line-exit ((t ,(list :foreground fresh-green :weight 'bold :inherit 'unspecified)))) + )) + +(provide-theme 'fleury) + + +;; MIT License + +;; Copyright (c) 2025 Shams Parvez Arka + +;; Permission is hereby granted, free of charge, to any person obtaining a copy +;; of this software and associated documentation files (the "Software"), to deal +;; in the Software without restriction, including without limitation the rights +;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;; copies of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice shall be included in all +;; copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. diff --git a/.emacs.d/themes/gruber-darker-theme.el b/.emacs.d/themes/gruber-darker-theme.el new file mode 100644 index 0000000..132f0b8 --- /dev/null +++ b/.emacs.d/themes/gruber-darker-theme.el @@ -0,0 +1,425 @@ +;;; gruber-darker-theme.el --- Gruber Darker color theme for Emacs 24. + +;; Copyright (C) 2013-2016 Alexey Kutepov a.k.a rexim +;; Copyright (C) 2009-2010 Jason R. Blevins + +;; Author: Alexey Kutepov +;; URL: http://github.com/rexim/gruber-darker-theme +;; Version: 0.7 + +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +;;; Commentary: +;; +;; Gruber Darker color theme for Emacs by Jason Blevins. A darker +;; variant of the Gruber Dark theme for BBEdit by John Gruber. Adapted +;; for deftheme and extended by Alexey Kutepov a.k.a. rexim. + + +(deftheme gruber-darker + "Gruber Darker color theme for Emacs 24") + +;; Please, install rainbow-mode. +;; Colors with +x are lighter. Colors with -x are darker. +(let ((gruber-darker-fg "#e4e4ef") + (gruber-darker-fg+1 "#f4f4ff") + (gruber-darker-fg+2 "#f5f5f5") + (gruber-darker-white "#ffffff") + (gruber-darker-black "#000000") + (gruber-darker-bg-1 "#101010") + (gruber-darker-bg "#181818") + (gruber-darker-bg+1 "#282828") + (gruber-darker-bg+2 "#453d41") + (gruber-darker-bg+3 "#484848") + (gruber-darker-bg+4 "#52494e") + (gruber-darker-red-1 "#c73c3f") + (gruber-darker-red "#f43841") + (gruber-darker-red+1 "#ff4f58") + (gruber-darker-green "#73c936") + (gruber-darker-yellow "#ffdd33") + (gruber-darker-brown "#cc8c3c") + (gruber-darker-quartz "#95a99f") + (gruber-darker-niagara-2 "#303540") + (gruber-darker-niagara-1 "#565f73") + (gruber-darker-niagara "#96a6c8") + (gruber-darker-wisteria "#9e95c7") + ) + (custom-theme-set-variables + 'gruber-darker + '(frame-brackground-mode (quote dark))) + + (custom-theme-set-faces + 'gruber-darker + + ;; Agda2 + `(agda2-highlight-datatype-face ((t (:foreground ,gruber-darker-quartz)))) + `(agda2-highlight-primitive-type-face ((t (:foreground ,gruber-darker-quartz)))) + `(agda2-highlight-function-face ((t (:foreground ,gruber-darker-niagara)))) + `(agda2-highlight-keyword-face ((t ,(list :foreground gruber-darker-yellow + :bold t)))) + `(agda2-highlight-inductive-constructor-face ((t (:foreground ,gruber-darker-green)))) + `(agda2-highlight-number-face ((t (:foreground ,gruber-darker-wisteria)))) + + ;; AUCTeX + `(font-latex-bold-face ((t (:foreground ,gruber-darker-quartz :bold t)))) + `(font-latex-italic-face ((t (:foreground ,gruber-darker-quartz :italic t)))) + `(font-latex-math-face ((t (:foreground ,gruber-darker-green)))) + `(font-latex-sectioning-5-face ((t ,(list :foreground gruber-darker-niagara + :bold t)))) + `(font-latex-slide-title-face ((t (:foreground ,gruber-darker-niagara)))) + `(font-latex-string-face ((t (:foreground ,gruber-darker-green)))) + `(font-latex-warning-face ((t (:foreground ,gruber-darker-red)))) + + ;; Basic Coloring (or Uncategorized) + `(border ((t ,(list :background gruber-darker-bg-1 + :foreground gruber-darker-bg+2)))) + `(cursor ((t (:background ,gruber-darker-yellow)))) + `(default ((t ,(list :foreground gruber-darker-fg + :background gruber-darker-bg)))) + `(fringe ((t ,(list :background nil + :foreground gruber-darker-bg+2)))) + `(vertical-border ((t ,(list :foreground gruber-darker-bg+2)))) + `(link ((t (:foreground ,gruber-darker-niagara :underline t)))) + `(link-visited ((t (:foreground ,gruber-darker-wisteria :underline t)))) + `(match ((t (:background ,gruber-darker-bg+4)))) + `(shadow ((t (:foreground ,gruber-darker-bg+4)))) + `(minibuffer-prompt ((t (:foreground ,gruber-darker-niagara)))) + `(region ((t (:background ,gruber-darker-bg+3 :foreground nil)))) + `(secondary-selection ((t ,(list :background gruber-darker-bg+3 + :foreground nil)))) + `(trailing-whitespace ((t ,(list :foreground gruber-darker-black + :background gruber-darker-red)))) + `(tooltip ((t ,(list :background gruber-darker-bg+4 + :foreground gruber-darker-white)))) + + ;; Calendar + `(holiday-face ((t (:foreground ,gruber-darker-red)))) + + ;; Compilation + `(compilation-info ((t ,(list :foreground gruber-darker-green + :inherit 'unspecified)))) + `(compilation-warning ((t ,(list :foreground gruber-darker-brown + :bold t + :inherit 'unspecified)))) + `(compilation-error ((t (:foreground ,gruber-darker-red+1)))) + `(compilation-mode-line-fail ((t ,(list :foreground gruber-darker-red + :weight 'bold + :inherit 'unspecified)))) + `(compilation-mode-line-exit ((t ,(list :foreground gruber-darker-green + :weight 'bold + :inherit 'unspecified)))) + + ;; Completion + `(completions-annotations ((t (:inherit 'shadow)))) + + ;; Custom + `(custom-state ((t (:foreground ,gruber-darker-green)))) + + ;; Diff + `(diff-removed ((t ,(list :foreground gruber-darker-red+1 + :background nil)))) + `(diff-added ((t ,(list :foreground gruber-darker-green + :background nil)))) + + ;; Dired + `(dired-directory ((t (:foreground ,gruber-darker-niagara :weight bold)))) + `(dired-ignored ((t ,(list :foreground gruber-darker-quartz + :inherit 'unspecified)))) + + ;; Ebrowse + `(ebrowse-root-class ((t (:foreground ,gruber-darker-niagara :weight bold)))) + `(ebrowse-progress ((t (:background ,gruber-darker-niagara)))) + + ;; Egg + `(egg-branch ((t (:foreground ,gruber-darker-yellow)))) + `(egg-branch-mono ((t (:foreground ,gruber-darker-yellow)))) + `(egg-diff-add ((t (:foreground ,gruber-darker-green)))) + `(egg-diff-del ((t (:foreground ,gruber-darker-red)))) + `(egg-diff-file-header ((t (:foreground ,gruber-darker-wisteria)))) + `(egg-help-header-1 ((t (:foreground ,gruber-darker-yellow)))) + `(egg-help-header-2 ((t (:foreground ,gruber-darker-niagara)))) + `(egg-log-HEAD-name ((t (:box (:color ,gruber-darker-fg))))) + `(egg-reflog-mono ((t (:foreground ,gruber-darker-niagara-1)))) + `(egg-section-title ((t (:foreground ,gruber-darker-yellow)))) + `(egg-text-base ((t (:foreground ,gruber-darker-fg)))) + `(egg-term ((t (:foreground ,gruber-darker-yellow)))) + + ;; ERC + `(erc-notice-face ((t (:foreground ,gruber-darker-wisteria)))) + `(erc-timestamp-face ((t (:foreground ,gruber-darker-green)))) + `(erc-input-face ((t (:foreground ,gruber-darker-red+1)))) + `(erc-my-nick-face ((t (:foreground ,gruber-darker-red+1)))) + + ;; EShell + `(eshell-ls-backup ((t (:foreground ,gruber-darker-quartz)))) + `(eshell-ls-directory ((t (:foreground ,gruber-darker-niagara)))) + `(eshell-ls-executable ((t (:foreground ,gruber-darker-green)))) + `(eshell-ls-symlink ((t (:foreground ,gruber-darker-yellow)))) + + ;; Font Lock + `(font-lock-builtin-face ((t (:foreground ,gruber-darker-yellow)))) + `(font-lock-comment-face ((t (:foreground ,gruber-darker-brown)))) + `(font-lock-comment-delimiter-face ((t (:foreground ,gruber-darker-brown)))) + `(font-lock-constant-face ((t (:foreground ,gruber-darker-quartz)))) + `(font-lock-doc-face ((t (:foreground ,gruber-darker-green)))) + `(font-lock-doc-string-face ((t (:foreground ,gruber-darker-green)))) + `(font-lock-function-name-face ((t (:foreground ,gruber-darker-niagara)))) + `(font-lock-keyword-face ((t (:foreground ,gruber-darker-yellow :bold t)))) + `(font-lock-preprocessor-face ((t (:foreground ,gruber-darker-quartz)))) + `(font-lock-reference-face ((t (:foreground ,gruber-darker-quartz)))) + `(font-lock-string-face ((t (:foreground ,gruber-darker-green)))) + `(font-lock-type-face ((t (:foreground ,gruber-darker-quartz)))) + `(font-lock-variable-name-face ((t (:foreground ,gruber-darker-fg+1)))) + `(font-lock-warning-face ((t (:foreground ,gruber-darker-red)))) + + ;; Flymake + `(flymake-errline + ((((supports :underline (:style wave))) + (:underline (:style wave :color ,gruber-darker-red) + :foreground unspecified + :background unspecified + :inherit unspecified)) + (t (:foreground ,gruber-darker-red :weight bold :underline t)))) + `(flymake-warnline + ((((supports :underline (:style wave))) + (:underline (:style wave :color ,gruber-darker-yellow) + :foreground unspecified + :background unspecified + :inherit unspecified)) + (t (:forground ,gruber-darker-yellow :weight bold :underline t)))) + `(flymake-infoline + ((((supports :underline (:style wave))) + (:underline (:style wave :color ,gruber-darker-green) + :foreground unspecified + :background unspecified + :inherit unspecified)) + (t (:forground ,gruber-darker-green :weight bold :underline t)))) + + ;; Flyspell + `(flyspell-incorrect + ((((supports :underline (:style wave))) + (:underline (:style wave :color ,gruber-darker-red) :inherit unspecified)) + (t (:foreground ,gruber-darker-red :weight bold :underline t)))) + `(flyspell-duplicate + ((((supports :underline (:style wave))) + (:underline (:style wave :color ,gruber-darker-yellow) :inherit unspecified)) + (t (:foreground ,gruber-darker-yellow :weight bold :underline t)))) + + ;; Helm + `(helm-candidate-number ((t ,(list :background gruber-darker-bg+2 + :foreground gruber-darker-yellow + :bold t)))) + `(helm-ff-directory ((t ,(list :foreground gruber-darker-niagara + :background gruber-darker-bg + :bold t)))) + `(helm-ff-executable ((t (:foreground ,gruber-darker-green)))) + `(helm-ff-file ((t (:foreground ,gruber-darker-fg :inherit unspecified)))) + `(helm-ff-invalid-symlink ((t ,(list :foreground gruber-darker-bg + :background gruber-darker-red)))) + `(helm-ff-symlink ((t (:foreground ,gruber-darker-yellow :bold t)))) + `(helm-selection-line ((t (:background ,gruber-darker-bg+1)))) + `(helm-selection ((t (:background ,gruber-darker-bg+1 :underline nil)))) + `(helm-source-header ((t ,(list :foreground gruber-darker-yellow + :background gruber-darker-bg + :box (list :line-width -1 + :style 'released-button))))) + + ;; Ido + `(ido-first-match ((t (:foreground ,gruber-darker-yellow :bold nil)))) + `(ido-only-match ((t (:foreground ,gruber-darker-brown :weight bold)))) + `(ido-subdir ((t (:foreground ,gruber-darker-niagara :weight bold)))) + + ;; Info + `(info-xref ((t (:foreground ,gruber-darker-niagara)))) + `(info-visited ((t (:foreground ,gruber-darker-wisteria)))) + + ;; Jabber + `(jabber-chat-prompt-foreign ((t ,(list :foreground gruber-darker-quartz + :bold nil)))) + `(jabber-chat-prompt-local ((t (:foreground ,gruber-darker-yellow)))) + `(jabber-chat-prompt-system ((t (:foreground ,gruber-darker-green)))) + `(jabber-rare-time-face ((t (:foreground ,gruber-darker-green)))) + `(jabber-roster-user-online ((t (:foreground ,gruber-darker-green)))) + `(jabber-activity-face ((t (:foreground ,gruber-darker-red)))) + `(jabber-activity-personal-face ((t (:foreground ,gruber-darker-yellow :bold t)))) + + ;; Line Highlighting + `(highlight ((t (:background ,gruber-darker-bg+1 :foreground nil)))) + `(highlight-current-line-face ((t ,(list :background gruber-darker-bg+1 + :foreground nil)))) + + ;; line numbers + `(line-number ((t (:inherit default :foreground ,gruber-darker-bg+4)))) + `(line-number-current-line ((t (:inherit line-number :foreground ,gruber-darker-yellow)))) + + ;; Linum + `(linum ((t `(list :foreground gruber-darker-quartz + :background gruber-darker-bg)))) + + ;; Magit + `(magit-branch ((t (:foreground ,gruber-darker-niagara)))) + `(magit-diff-hunk-header ((t (:background ,gruber-darker-bg+2)))) + `(magit-diff-file-header ((t (:background ,gruber-darker-bg+4)))) + `(magit-log-sha1 ((t (:foreground ,gruber-darker-red+1)))) + `(magit-log-author ((t (:foreground ,gruber-darker-brown)))) + `(magit-log-head-label-remote ((t ,(list :foreground gruber-darker-green + :background gruber-darker-bg+1)))) + `(magit-log-head-label-local ((t ,(list :foreground gruber-darker-niagara + :background gruber-darker-bg+1)))) + `(magit-log-head-label-tags ((t ,(list :foreground gruber-darker-yellow + :background gruber-darker-bg+1)))) + `(magit-log-head-label-head ((t ,(list :foreground gruber-darker-fg + :background gruber-darker-bg+1)))) + `(magit-item-highlight ((t (:background ,gruber-darker-bg+1)))) + `(magit-tag ((t ,(list :foreground gruber-darker-yellow + :background gruber-darker-bg)))) + `(magit-blame-heading ((t ,(list :background gruber-darker-bg+1 + :foreground gruber-darker-fg)))) + + ;; Message + `(message-header-name ((t (:foreground ,gruber-darker-green)))) + + ;; Mode Line + `(mode-line ((t ,(list :background gruber-darker-bg+1 + :foreground gruber-darker-white)))) + `(mode-line-buffer-id ((t ,(list :background gruber-darker-bg+1 + :foreground gruber-darker-white)))) + `(mode-line-inactive ((t ,(list :background gruber-darker-bg+1 + :foreground gruber-darker-quartz)))) + + ;; Neo Dir + `(neo-dir-link-face ((t (:foreground ,gruber-darker-niagara)))) + + ;; Org Mode + `(org-agenda-structure ((t (:foreground ,gruber-darker-niagara)))) + `(org-column ((t (:background ,gruber-darker-bg-1)))) + `(org-column-title ((t (:background ,gruber-darker-bg-1 :underline t :weight bold)))) + `(org-done ((t (:foreground ,gruber-darker-green)))) + `(org-todo ((t (:foreground ,gruber-darker-red-1)))) + `(org-upcoming-deadline ((t (:foreground ,gruber-darker-yellow)))) + + ;; Search + `(isearch ((t ,(list :foreground gruber-darker-black + :background gruber-darker-fg+2)))) + `(isearch-fail ((t ,(list :foreground gruber-darker-black + :background gruber-darker-red)))) + `(isearch-lazy-highlight-face ((t ,(list + :foreground gruber-darker-fg+1 + :background gruber-darker-niagara-1)))) + + ;; Sh + `(sh-quoted-exec ((t (:foreground ,gruber-darker-red+1)))) + + ;; Show Paren + `(show-paren-match-face ((t (:background ,gruber-darker-bg+4)))) + `(show-paren-mismatch-face ((t (:background ,gruber-darker-red-1)))) + + ;; Slime + `(slime-repl-inputed-output-face ((t (:foreground ,gruber-darker-red)))) + + ;; Tuareg + `(tuareg-font-lock-governing-face ((t (:foreground ,gruber-darker-yellow)))) + + ;; Speedbar + `(speedbar-directory-face ((t ,(list :foreground gruber-darker-niagara + :weight 'bold)))) + `(speedbar-file-face ((t (:foreground ,gruber-darker-fg)))) + `(speedbar-highlight-face ((t (:background ,gruber-darker-bg+1)))) + `(speedbar-selected-face ((t (:foreground ,gruber-darker-red)))) + `(speedbar-tag-face ((t (:foreground ,gruber-darker-yellow)))) + + ;; Which Function + `(which-func ((t (:foreground ,gruber-darker-wisteria)))) + + ;; Whitespace + `(whitespace-space ((t ,(list :background gruber-darker-bg + :foreground gruber-darker-bg+1)))) + `(whitespace-tab ((t ,(list :background gruber-darker-bg + :foreground gruber-darker-bg+1)))) + `(whitespace-hspace ((t ,(list :background gruber-darker-bg + :foreground gruber-darker-bg+2)))) + `(whitespace-line ((t ,(list :background gruber-darker-bg+2 + :foreground gruber-darker-red+1)))) + `(whitespace-newline ((t ,(list :background gruber-darker-bg + :foreground gruber-darker-bg+2)))) + `(whitespace-trailing ((t ,(list :background gruber-darker-red + :foreground gruber-darker-red)))) + `(whitespace-empty ((t ,(list :background gruber-darker-yellow + :foreground gruber-darker-yellow)))) + `(whitespace-indentation ((t ,(list :background gruber-darker-yellow + :foreground gruber-darker-red)))) + `(whitespace-space-after-tab ((t ,(list :background gruber-darker-yellow + :foreground gruber-darker-yellow)))) + `(whitespace-space-before-tab ((t ,(list :background gruber-darker-brown + :foreground gruber-darker-brown)))) + + ;; tab-bar + `(tab-bar ((t (:background ,gruber-darker-bg+1 :foreground ,gruber-darker-bg+4)))) + `(tab-bar-tab ((t (:background nil :foreground ,gruber-darker-yellow :weight bold)))) + `(tab-bar-tab-inactive ((t (:background nil)))) + + ;; vterm / ansi-term + `(term-color-black ((t (:foreground ,gruber-darker-bg+3 :background ,gruber-darker-bg+4)))) + `(term-color-red ((t (:foreground ,gruber-darker-red-1 :background ,gruber-darker-red-1)))) + `(term-color-green ((t (:foreground ,gruber-darker-green :background ,gruber-darker-green)))) + `(term-color-blue ((t (:foreground ,gruber-darker-niagara :background ,gruber-darker-niagara)))) + `(term-color-yellow ((t (:foreground ,gruber-darker-yellow :background ,gruber-darker-yellow)))) + `(term-color-magenta ((t (:foreground ,gruber-darker-wisteria :background ,gruber-darker-wisteria)))) + `(term-color-cyan ((t (:foreground ,gruber-darker-quartz :background ,gruber-darker-quartz)))) + `(term-color-white ((t (:foreground ,gruber-darker-fg :background ,gruber-darker-white)))) + + ;; company-mode + `(company-tooltip ((t (:foreground ,gruber-darker-fg :background ,gruber-darker-bg+1)))) + `(company-tooltip-annotation ((t (:foreground ,gruber-darker-brown :background ,gruber-darker-bg+1)))) + `(company-tooltip-annotation-selection ((t (:foreground ,gruber-darker-brown :background ,gruber-darker-bg-1)))) + `(company-tooltip-selection ((t (:foreground ,gruber-darker-fg :background ,gruber-darker-bg-1)))) + `(company-tooltip-mouse ((t (:background ,gruber-darker-bg-1)))) + `(company-tooltip-common ((t (:foreground ,gruber-darker-green)))) + `(company-tooltip-common-selection ((t (:foreground ,gruber-darker-green)))) + `(company-scrollbar-fg ((t (:background ,gruber-darker-bg-1)))) + `(company-scrollbar-bg ((t (:background ,gruber-darker-bg+2)))) + `(company-preview ((t (:background ,gruber-darker-green)))) + `(company-preview-common ((t (:foreground ,gruber-darker-green :background ,gruber-darker-bg-1)))) + + ;; Proof General + `(proof-locked-face ((t (:background ,gruber-darker-niagara-2)))) + + ;; Orderless + `(orderless-match-face-0 ((t (:foreground ,gruber-darker-yellow)))) + `(orderless-match-face-1 ((t (:foreground ,gruber-darker-green)))) + `(orderless-match-face-2 ((t (:foreground ,gruber-darker-brown)))) + `(orderless-match-face-3 ((t (:foreground ,gruber-darker-quartz)))) + )) + +;;;###autoload +(when load-file-name + (add-to-list 'custom-theme-load-path + (file-name-as-directory (file-name-directory load-file-name)))) + +(provide-theme 'gruber-darker) + +;; Local Variables: +;; no-byte-compile: t +;; indent-tabs-mode: nil +;; eval: (when (fboundp 'rainbow-mode) (rainbow-mode +1)) +;; End: + +;;; gruber-darker-theme.el ends here. diff --git a/.emacs.d/themes/handmade-theme.el b/.emacs.d/themes/handmade-theme.el new file mode 100644 index 0000000..3b9747d --- /dev/null +++ b/.emacs.d/themes/handmade-theme.el @@ -0,0 +1,71 @@ +;;; handmade-theme.el --- A Handmade theme -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Niko Pavlinek + +;; This is free and unencumbered software released into the public domain. + +;; Anyone is free to copy, modify, publish, use, compile, sell, or distribute +;; this software, either in source code form or as a compiled binary, for any +;; purpose, commercial or non-commercial, and by any means. + +;; In jurisdictions that recognize copyright laws, the author or authors of this +;; software dedicate any and all copyright interest in the software to the +;; public domain. We make this dedication for the benefit of the public at large +;; and to the detriment of our heirs and successors. We intend this dedication +;; to be an overt act of relinquishment in perpetuity of all present and future +;; rights to this software under copyright law. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;; AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE,ARISING FROM, OUT OF OR IN CONNECTION +;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;; For more information, please refer to + +(deftheme handmade + "A port of the Emacs theme used by Casey Muratori on the Handmade Hero series.") + +(defface handmade-important-face nil "") +(defface handmade-note-face nil "") +(defface handmade-todo-face nil "") + +(mapc (lambda (mode) + (font-lock-add-keywords mode '(("\\<\\(IMPORTANT\\)" 1 'handmade-important-face t) + ("\\<\\(NOTE\\)" 1 'handmade-note-face t) + ("\\<\\(STUDY\\)" 1 'handmade-important-face t) + ("\\<\\(TODO\\)" 1 'handmade-todo-face t) + ("\\<\\(XXX\\)" 1 'handmade-todo-face t)))) + '(c-mode c++-mode emacs-lisp-mode)) + +(let ((handmade-beige "burlywood3") + (handmade-dark-blue "midnight blue") + (handmade-dark-gray "#161616") + (handmade-dark-green "DarkGreen") + (handmade-gold "DarkGoldenrod3") + (handmade-light-beige "#dab98f") + (handmade-light-gray "gray50") + (handmade-light-green "#40ff40") + (handmade-olive "olive drab") + (handmade-red "Red") + (handmade-yellow "Yellow")) + (custom-theme-set-faces + 'handmade + `(cursor ((t (:background ,handmade-light-green)))) + `(default ((t (:background ,handmade-dark-gray :foreground ,handmade-beige)))) + `(font-lock-builtin-face ((t (:foreground ,handmade-light-beige)))) + `(font-lock-comment-face ((t (:foreground ,handmade-light-gray)))) + `(font-lock-constant-face ((t (:foreground ,handmade-olive)))) + `(font-lock-doc-face ((t (:foreground ,handmade-light-gray)))) + `(font-lock-function-name-face ((t (:foreground ,handmade-beige)))) + `(font-lock-keyword-face ((t (:foreground ,handmade-gold)))) + `(font-lock-string-face ((t (:foreground ,handmade-olive)))) + `(font-lock-type-face ((t (:foreground ,handmade-beige)))) + `(font-lock-variable-name-face ((t (:foreground ,handmade-beige)))) + `(handmade-important-face ((t (:foreground ,handmade-yellow :weight bold :underline t)))) + `(handmade-note-face ((t (:foreground ,handmade-dark-green :weight bold :underline t)))) + `(handmade-todo-face ((t (:foreground ,handmade-red :weight bold :underline t)))) + `(hl-line ((t (:background ,handmade-dark-blue)))))) + +(provide-theme 'handmade) diff --git a/.emacs.d/themes/witness-theme.el b/.emacs.d/themes/witness-theme.el new file mode 100644 index 0000000..b816d55 --- /dev/null +++ b/.emacs.d/themes/witness-theme.el @@ -0,0 +1,37 @@ +;;; witness-theme.el --- Witness color theme -*- lexical-binding: t; -*- + +;;; Commentary: +;; A dark teal color theme. + +;;; Code: + +(deftheme witness + "Witness color theme - dark teal with green accents.") + +(custom-theme-set-faces + 'witness + ;; Basic faces + '(default ((t (:foreground "#d3b58d" :background "#072626")))) + '(cursor ((t (:background "lightgreen")))) + '(region ((t (:background "blue")))) + '(highlight ((t (:foreground "navyblue" :background "darkseagreen2")))) + '(mode-line ((t (:inverse-video t)))) + + ;; Font lock faces + '(font-lock-builtin-face ((t (:foreground "lightgreen")))) + '(font-lock-comment-face ((t (:foreground "#3fdf1f")))) + '(font-lock-string-face ((t (:foreground "#0fdfaf")))) + '(font-lock-keyword-face ((t (:foreground "white")))) + '(font-lock-function-name-face ((t (:foreground "white")))) + '(font-lock-variable-name-face ((t (:foreground "#c8d4ec")))) + '(font-lock-warning-face ((t (:foreground "#504038")))) + + ;; Custom/widget faces + '(custom-group-tag ((t (:underline t :foreground "lightblue")))) + '(custom-variable-tag ((t (:underline t :foreground "lightblue")))) + '(widget-field ((t (:foreground "white")))) + '(widget-single-line-field ((t (:background "darkgray"))))) + +(provide-theme 'witness) + +;;; witness-theme.el ends here