diff options
Diffstat (limited to 'elpa/counsel-20200706.1447/counsel.el')
| -rw-r--r-- | elpa/counsel-20200706.1447/counsel.el | 6850 |
1 files changed, 0 insertions, 6850 deletions
diff --git a/elpa/counsel-20200706.1447/counsel.el b/elpa/counsel-20200706.1447/counsel.el deleted file mode 100644 index acd0972..0000000 --- a/elpa/counsel-20200706.1447/counsel.el +++ /dev/null @@ -1,6850 +0,0 @@ -;;; counsel.el --- Various completion functions using Ivy -*- lexical-binding: t -*- - -;; Copyright (C) 2015-2019 Free Software Foundation, Inc. - -;; Author: Oleh Krehel <ohwoeowho@gmail.com> -;; URL: https://github.com/abo-abo/swiper -;; Package-Version: 20200706.1447 -;; Package-Commit: c6b60d34ac37bf4d91a25f16d22e528f85e06938 -;; Version: 0.13.0 -;; Package-Requires: ((emacs "24.5") (swiper "0.13.0")) -;; 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 <https://www.gnu.org/licenses/>. - -;;; 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 'swiper) - -(require 'compile) -(require 'dired) - -(eval-when-compile - (require 'subr-x)) - -(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 (string-match-p "|" 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)) - -(defun counsel-require-program (cmd) - "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." - (unless (and (stringp cmd) (string-match-p "^ " cmd)) - (let ((program (if (listp cmd) - (car cmd) - (car (split-string cmd))))) - (or (and (stringp program) - (not (string= program "")) - (executable-find program)) - (user-error "Required program \"%s\" not found in your path" program))))) - -(declare-function eshell-split-path "esh-util") - -(defun counsel-prompt-function-dir () - "Return prompt appended with the parent directory." - (require 'esh-util) - (let* ((dir (ivy-state-directory ivy-last)) - (parts (nthcdr 3 (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)))) - -;;* 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) - -(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 (list 0 0 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-remove-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 "<2020-05-20 Wed>") -(define-obsolete-function-alias 'counsel-cl 'complete-symbol "<2020-05-20 Wed>") -(define-obsolete-function-alias 'counsel-jedi 'complete-symbol "<2020-05-20 Wed>") -(define-obsolete-function-alias 'counsel-clj 'complete-symbol "<2020-05-20 Wed>") - -;;** `counsel-company' -(defvar company-candidates) -(defvar company-common) -(defvar company-prefix) -(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") - -;;;###autoload -(defun counsel-company () - "Complete using `company-candidates'." - (interactive) - (company-mode 1) - (unless company-candidates - (company-complete)) - (let ((len (cond ((let (l) - (and company-common - (string= company-common - (buffer-substring - (- (point) (setq l (length company-common))) - (point))) - l))) - (company-prefix - (length company-prefix))))) - (when len - (setq ivy-completion-beg (- (point) len)) - (setq ivy-completion-end (point)) - (ivy-read "Candidate: " company-candidates - :action #'ivy-completion-in-region-action - :caller 'counsel-company)))) - -(ivy-configure 'counsel-company - :display-transformer-fn #'counsel--company-display-transformer - :unwind-fn #'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))) - -(add-to-list 'ivy-display-functions-alist '(counsel-irony . 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)) -(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)) - -(defvar find-tag-marker-ring) -(declare-function xref-push-marker-stack "xref") - -(defalias 'counsel--push-xref-marker - ;; Added in Emacs 25.1. - (if (require 'xref nil t) - #'xref-push-marker-stack - (require 'etags) - (lambda (&optional m) - (ring-insert (with-no-warnings find-tag-marker-ring) (or m (point-marker))))) - "Compatibility shim for `xref-push-marker-stack'.") - -(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))) - -;;;###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 (lambda (x) - (funcall counsel-describe-function-function (intern x))) - :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) - (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* ((minibuffer-completing-symbol t) - (sym-value (symbol-value sym)) - (expr (minibuffer-with-setup-hook - (lambda () - ;; Functions `elisp-eldoc-documentation-function' and - ;; `elisp-completion-at-point' added in Emacs 25.1. - (add-function :before-until (local 'eldoc-documentation-function) - #'elisp-eldoc-documentation-function) - (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil t) - (run-hooks 'eval-expression-minibuffer-setup-hook) - (goto-char (minibuffer-prompt-end)) - (forward-char 6) - (insert (format "%S " sym))) - (read-from-minibuffer "Eval: " - (format - (if (and sym-value (or (consp sym-value) - (symbolp sym-value))) - "(setq '%S)" - "(setq %S)") - sym-value) - read-expression-map t - 'read-expression-history)))) - expr)) - -(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 `<f2>' 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-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 - (lambda (x) - (not (get (intern x) 'no-counsel-M-x))) - (lambda (sym) - (and (commandp sym) - (not (get sym 'byte-obsolete-info)) - (not (get sym 'no-counsel-M-x))))) - :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" ,(lambda (x) (funcall counsel-describe-function-function (intern x))) "help"))) - -;;** `counsel-command-history' -(defun counsel-command-history-action-eval (cmd) - "Eval the command CMD." - (eval (read cmd))) - -(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 - '("<vertical-line>" "<bottom-divider>" "<right-divider>" - "<mode-line>" "<C-down-mouse-2>" "<left-fringe>" - "<right-fringe>" "<header-line>" - "<vertical-scroll-bar>" "<horizontal-scroll-bar>"))) - res) - (with-temp-buffer - (let ((indent-tabs-mode t)) - (describe-buffer-bindings buffer prefix)) - (goto-char (point-min)) - ;; Skip the "Key translations" section - (re-search-forward " ") - (forward-char 1) - (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 re-exclude key) - (not (or (commandp (setq cmd (intern-soft fun))) - (member fun '("Prefix Command"))))) - (push - (cons (format - "%-15s %s" - (propertize key 'face 'counsel-key-binding) - fun) - (cons key cmd)) - res)))) - (forward-line 1))) - (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))) - -(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"))) - -;;* 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))) - -;;;###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 - :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) - (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) - (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. -Typical value: '(recenter)." - :type 'hook) - -(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) - (replace-regexp-in-string - "\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) - (progn - (counsel--async-command - (concat - (funcall counsel-git-grep-cmd-function string) - (if (ivy--case-fold-p string) " -i" ""))) - nil))) - -(defun counsel-git-grep-action (x) - "Go to occurrence X in current Git repository." - (when (string-match "\\`\\(.*?\\):\\([0-9]+\\):\\(.*\\)\\'" x) - (let ((file-name (match-string-no-properties 1 x)) - (line-number (match-string-no-properties 2 x))) - (find-file (expand-file-name - file-name - (ivy-state-directory ivy-last))) - (goto-char (point-min)) - (forward-line (1- (string-to-number 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)))) - (swiper--ensure-visible) - (run-hooks 'counsel-grep-post-action-hook) - (unless (eq ivy-exit 'done) - (swiper--cleanup) - (swiper--add-overlays (ivy--regex ivy-text)))))) - -(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 (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 (replace-regexp-in-string - ;; git-grep can't handle .*? - "\\.\\*\\?" ".*" - (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 - (replace-regexp-in-string "\\.\\*\\?" ".*" - (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 (string-match-p " " 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 (string-match-p " " 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") - "\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-<backspace>") 'counsel-up-directory) - (define-key map (kbd "`") (ivy-make-magic-action 'counsel-find-file "b")) - (define-key map [remap undo] 'counsel-find-file-undo) - map)) - -(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." - (require '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." - (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." - (require '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. -\\<ivy-minibuffer-map> -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" - ,(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." - (with-ivy-window - (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) - (let ((default-directory - (if (eq major-mode '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) - "Forward to `find-file'. -When INITIAL-INPUT is non-nil, use it in the minibuffer during completion." - (interactive) - (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-match-p "csh\\'" shell-file-name) - (replace-regexp-in-string "\\?!" "?\\\\!" 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 - (if (string-match "^\\." ivy-text) - "" - " | grep -v '/\\\\.'"))) - (replace-regexp-in-string - " | 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 (string-match-p "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]+") - (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." - (counsel-require-program "git") - (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." - (counsel-require-program "git") - (let ((url (counsel-at-git-issue-p))) - (when url - (let ((origin (shell-command-to-string - "git remote get-url origin"))) - (when (string-match "git.sv.gnu.org:/srv/git/emacs.git" origin) - (format "https://debbugs.gnu.org/cgi/bugreport.cgi?bug=%s" - (substring url 1))))))) - -(defvar counsel-url-expansions-alist nil - "Map of regular expressions to expansions. - -This variable should take the form of a list of (REGEXP . FORMAT) -pairs. - -`counsel-url-expand' will expand 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 will be used as the -format string for the `format' function, with the word at point -as the next argument. If it is a function, it will be 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\") -will expand to URL `https://jira.atlassian.com/browse/BSERV-100' -when the word at point is BSERV-100. - -If the format element is a function, more powerful -transformations are possible. As an example, - '(\"\\`issue\\([[:digit:]]+\\)\\'\" . - (lambda (word) - (concat \"https://debbugs.gnu.org/cgi/bugreport.cgi?bug=\" - (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' -(declare-function dired "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) - (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) - (require 'recentf) - (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 "<xml/>") - (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 (require 'dom nil t) - (user-error "This function requires Emacs 25.1 or later")) - (declare-function dom-attr "dom" (node attr)) - (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)) - (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'." - (require 'recentf) - (recentf-mode) - (let ((buffers - (delq nil - (mapcar (lambda (b) - (when (buffer-file-name b) - (buffer-file-name b))) - (buffer-list))))) - (append - 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 - `(("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-remove-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))) - -(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) - -(declare-function dired-jump "dired-x") - -(defun counsel-locate-action-dired (x) - "Use `dired-jump' on X." - (dired-jump nil x)) - -(defun counsel-locate-cmd-default (input) - "Return a shell command based on INPUT." - (counsel-require-program "locate") - (format "locate -i --regex '%s'" - (counsel--elisp-to-pcre - (ivy--regex input)))) - -(defun counsel-locate-cmd-noregex (input) - "Return a shell command based on INPUT." - (counsel-require-program "locate") - (format "locate -i '%s'" input)) - -(defun counsel-locate-cmd-mdfind (input) - "Return a shell command based on INPUT." - (counsel-require-program "mdfind") - (format "mdfind -name '%s'" input)) - -(defvar w32-ansi-code-page) - -(defun counsel-locate-cmd-es (input) - "Return a shell command based on INPUT." - (counsel-require-program "es.exe") - (let ((raw-string (format "es.exe -i -p -r %s" - (counsel--elisp-to-pcre - (ivy--regex input t))))) - ;; W32 don't use Unicode by default, so we encode search command - ;; to local codepage to support searching filename contains 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 the \"locate\" 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." - (> (time-to-seconds - (time-subtract - (current-time) - (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 the \"locate\" shell command. -INITIAL-INPUT can be given as the initial minibuffer input." - (interactive) - (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' -;;;###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 - :caller 'counsel-file-jump))) - -(ivy-set-actions - 'counsel-file-jump - `(("d" ,(lambda (x) - (dired (or (file-name-directory x) default-directory))) - "open in dired"))) - -(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)) - -;;** `counsel-dired-jump' -;;;###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 "ag --vimgrep %s" - "Format string to use in `counsel-ag-function' to construct the command. -The %s will be replaced by optional extra ag arguments followed by the -regex string." - :type '(radio - (const "ag --vimgrep %s") - (const "ag --nocolor --nogroup %s") - (string :tag "custom"))) - -(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 (car command-args) - (counsel--ag-extra-switches regex) - (if (ivy--case-fold-p string) - " -i " - " -s ")))) - (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 from user, a (partial) replacement of `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-match-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 - (and (string-match "\"\\(.*\\)\"" (buffer-name)) - (match-string 1 (buffer-name)))) - (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))) - (all-args (append - (when (car command-args) - (split-string (car command-args))) - (counsel--ag-extra-switches regex) - (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 - (split-string - (if (memq system-type '(ms-dos windows-nt)) - "rg -M 240 --with-filename --no-heading --line-number --color never %s --path-separator / ." - "rg -M 240 --with-filename --no-heading --line-number --color never %s")) - "Alternative to `counsel-ag-base-command' using ripgrep. - -Note: don't use single quotes for the regex." - :type '(choice - (repeat :tag "List to be used in `process-file'." string) - (string :tag "String to be used in `shell-command-to-string'."))) - -(defun counsel--rg-targets () - "Return a list of files to operate on, based on `dired-mode' marks." - (when (eq major-mode 'dired-mode) - (let ((files - (dired-get-marked-files 'no-dir nil nil t))) - (when (or (cdr files) - (when (string-match-p "\\*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'." - (counsel-grep-like-occur - (format - "grep -niE %%s %s /dev/null" - (shell-quote-argument - (file-name-nondirectory - (buffer-file-name - (ivy-state-buffer ivy-last))))))) - -(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-string "org") -(declare-function org-get-tags "org") -(declare-function org-make-tag-string "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) - -(declare-function org-get-at-bol "org") -(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' -(defvar org-entities) -(defvar org-entities-user) - -;;;###autoload -(defun counsel-org-entity () - "Complete Org entities using Ivy." - (interactive) - (require 'org) - (ivy-read "Entity: " (cl-loop for element in (append org-entities org-entities-user) - unless (stringp element) - collect (cons - (format "%20s | %20s | %20s | %s" - (cl-first element) ; name - (cl-second element) ; latex - (cl-fourth element) ; html - (cl-seventh element)) ; utf-8 - element)) - :require-match t - :action '(1 - ("u" (lambda (candidate) - (insert (cl-seventh (cdr candidate)))) "utf-8") - ("o" (lambda (candidate) - (insert "\\" (cl-first (cdr candidate)))) "org-entity") - ("l" (lambda (candidate) - (insert (cl-second (cdr candidate)))) "latex") - ("h" (lambda (candidate) - (insert (cl-fourth (cdr candidate)))) "html") - ("a" (lambda (candidate) - (insert (cl-fifth (cdr candidate)))) "ascii") - ("L" (lambda (candidate) - (insert (cl-sixth (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: " - (delq nil - (mapcar - (lambda (x) - (when (> (length x) 2) - (format "%-5s %s" (nth 0 x) (nth 1 x)))) - ;; We build the list of capture templates as in - ;; `org-capture-select-template': - (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-set-startup-visibility "org") -(declare-function org-show-entry "org") -(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)) - (org-set-startup-visibility) - (goto-char (nth 2 headline)) - (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 - (mapconcat - 'identity - (cl-remove-if 'null - (list - level - todo - (and priority (format "[#%c]" priority)) - (mapconcat 'identity - (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' -(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 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 (candidates caller) - "call `ivy-read' with sane defaults for traversing marks. -CANDIDATES should be an alist with the `car' of the list being -the string displayed by ivy and the `cdr' being the point that -mark should take you to. - -NOTE This has been abstracted out into it's own method so it can -be used by both `counsel-mark-ring' and `counsel-evil-marks'" - (ivy-read "Mark: " 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-not - (lambda (x) (not (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 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") - -(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-minibuffer-map> - - \\[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)) - -(cl-pushnew '(counsel-package . "^+") ivy-initial-inputs-alist :key #'car) - -(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' -(defvar tmm-km-list nil) -(declare-function tmm-get-keymap "tmm") -(declare-function tmm--completion-table "tmm") -(declare-function tmm-get-keybind "tmm") - -(defun counsel-tmm-prompt (menu) - "Select and call an item from the MENU keymap." - (let (out - choice - chosen-string) - (setq tmm-km-list nil) - (map-keymap (lambda (k v) (tmm-get-keymap (cons k v))) menu) - (setq tmm-km-list (nreverse tmm-km-list)) - (setq out (ivy-read "Menu bar: " (tmm--completion-table tmm-km-list) - :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))))) - -(defvar tmm-table-undef) - -;;;###autoload -(defun counsel-tmm () - "Text-mode emulation of looking and choosing from a menu bar." - (interactive) - (require 'tmm) - (run-hooks 'menu-bar-update-hook) - (setq tmm-table-undef nil) - (counsel-tmm-prompt (tmm-get-keybind [menu-bar]))) - -;;** `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))) - -(defun counsel--yank-pop-position (s) - "Return position of S in `kill-ring' relative to last yank." - (or (cl-position s kill-ring-yank-pointer :test #'equal-including-properties) - (cl-position s kill-ring-yank-pointer :test #'equal) - (+ (or (cl-position s kill-ring :test #'equal-including-properties) - (cl-position s kill-ring :test #'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." - (not (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) - (function :tag "Other"))) - -(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 - (dolist (sym '(kill-ring kill-ring-yank-pointer)) - (set sym (cl-delete-duplicates - (cl-delete-if-not counsel-yank-pop-filter (symbol-value sym)) - :test #'equal-including-properties :from-end t))) - kill-ring) - -(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." - (with-ivy-window - (barf-if-buffer-read-only) - (setq last-command 'yank) - (setq yank-window-start (window-start)) - (condition-case nil - ;; Avoid unexpected additions to `kill-ring' - (let (interprogram-paste-function) - (yank-pop (counsel--yank-pop-position s))) - (error - (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." - (dolist (sym '(kill-ring kill-ring-yank-pointer)) - (set sym (cl-delete s (symbol-value sym) - :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) - -;; Moved to subr.el in Emacs 27.1. -(autoload 'xor "array") - -;;;###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))) - -(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)))) - -;;** `counsel-imenu' -(defvar imenu-auto-rescan) -(defvar imenu-auto-rescan-maxout) -(declare-function imenu--subalist-p "imenu") -(declare-function imenu--make-index-alist "imenu") - -(defun counsel--imenu-candidates () - (require 'imenu) - (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 (if (eq major-mode 'emacs-lisp-mode) - (counsel-imenu-categorize-functions items) - 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 - (nconc (cl-remove-if #'nlistp items :key #'cdr) - `(("Functions" ,@fns))) - items))) - -(defun counsel-imenu-action (x) - (with-ivy-window - (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) - (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) -(defvar counsel-shell-history--index-last) -(defvar counsel-slime-repl-history--index-last) - -(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)) - (counsel-slime-repl-history - (setq slime-repl-input-history-position snd - counsel-slime-repl-history--index-last snd))) - (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) - -(defvar counsel-esh--index-last nil - "Index corresponding to last selection with `counsel-esh-history'.") - -;;;###autoload -(defun counsel-esh-history () - "Browse Eshell history." - (interactive) - (require 'em-hist) - (counsel--browse-history eshell-history-ring - :caller #'counsel-esh-history)) - -(defadvice eshell-previous-matching-input (before - counsel-set-eshell-history-index - activate) - "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) - -(defvar counsel-shell-history--index-last nil - "Index corresponding to last selection with `counsel-shell-history'.") - -;;;###autoload -(defun counsel-shell-history () - "Browse shell history." - (interactive) - (require 'comint) - (counsel--browse-history comint-input-ring - :caller #'counsel-shell-history)) - -(defadvice comint-previous-matching-input (before - counsel-set-comint-history-index - activate) - "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) - -(defvar counsel-slime-repl-history--index-last nil - "Index corresponding to last selection with `counsel-slime-repl-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 - -;;** `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 (eval (intern (concat base "heads")))) - (keymap (eval (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' -(declare-function org-trim "org-macs") - -(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)))))) - -(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 list of buffer-related lines in Ibuffer as strings." - (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 (cdr x))) - -(defun counsel-ibuffer-visit-buffer-other-window (x) - "Switch to buffer of candidate X in another window." - (switch-to-buffer-other-window (cdr 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"))) - -;;** `counsel-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"))) - -;;;###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)) - -(defun counsel-kmacro-kill () - "Kill the line, or delete the keyboard macro." - (interactive) - (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))) - -;;;###autoload -(defun counsel-kmacro () - "Interactively choose and run a keyboard macro. - -With prefix argument, run macro that many times. - -Macros are run using the current value of `kmacro-counter-value' -and their respective counter format. Displayed next to each macro is -the counter's format and initial value. - -One can use actions to copy the counter format or initial counter -value of a macro, using them for a new macro." - (interactive) - (if (or last-kbd-macro kmacro-ring) - (ivy-read - (concat "Execute macro (counter at " - (number-to-string (or kmacro-initial-counter-value kmacro-counter)) - "): ") - (counsel--kmacro-candidates) - :keymap counsel-kmacro-map - :require-match t - :action #'counsel-kmacro-action-run - :caller 'counsel-kmacro) - (user-error "No keyboard macros defined"))) - -(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)) - (lambda (str) str) - formatted-kmacro - (propertize counsel-kmacro-separator 'face 'ivy-separator))) - -(defun counsel--kmacro-candidates () - "Create the list of keyboard macros used by `counsel-kmacro'. -This is a combination of `kmacro-ring' and, together in a list, `last-kbd-macro', -`kmacro-counter-format-start', and `kmacro-counter-value-start'." - (mapcar - (lambda (kmacro) - (cons - (concat "(" (nth 2 kmacro) "," (number-to-string (nth 1 kmacro)) "): " - (condition-case nil - (format-kbd-macro (if (listp kmacro) (car kmacro) kmacro) 1) - ;; Recover from error from `edmacro-fix-menu-commands'. - (error "Warning: Cannot display macros containing mouse clicks"))) - kmacro)) - (cons - (if (listp last-kbd-macro) - last-kbd-macro - (list - last-kbd-macro - kmacro-counter-value-start - kmacro-counter-format-start)) - kmacro-ring))) - -(defun counsel-kmacro-action-run (x) - "Run keyboard macro." - (let* ((actual-kmacro (cdr x)) - (kmacro-keys (nth 0 actual-kmacro)) - (kmacro-counter-format-start (nth 2 actual-kmacro))) - ;; With prefix argument, call the macro that many times. - (kmacro-call-macro (or current-prefix-arg 1) t nil kmacro-keys))) - -(defun counsel-kmacro-action-delete-kmacro (x) - "Delete a keyboard macro from within `counsel-kmacro'. - -Either delete a macro from `kmacro-ring', or set `last-kbd-macro' -to the popped head of the ring." - (let ((actual-macro (cdr x))) - (if (eq (nth 0 actual-macro) last-kbd-macro) - (setq last-kbd-macro - (if (eq kmacro-ring nil) - nil - (let ((prev-macro (pop kmacro-ring))) - (if (listp prev-macro) - (nth 0 prev-macro) - prev-macro)))) - (setq kmacro-ring (delq actual-macro kmacro-ring))))) - -(defun counsel-kmacro-action-copy-initial-counter-value (x) - "Pass an existing keyboard macro's original value to `kmacro-set-counter'. -This value will be used by the next executed macro, or as an -initial value by the next macro defined. - -Note that calling an existing macro that itself uses a counter -effectively resets the initial counter value for the next defined macro -to 0." - ;; NOTE: - ;; Calling `kmacro-start-macro' without an argument sets `kmacro-counter' - ;; to 0 if `kmacro-initial-counter'is nil, and sets `kmacro-initial-counter' - ;; to nil regardless. - ;; Using `kmacro-insert-counter' sets `kmacro-initial-counter' to nil. - (let* ((actual-kmacro (cdr x)) - (number (nth 1 actual-kmacro))) - (kmacro-set-counter number))) - -(defun counsel-kmacro-action-copy-counter-format-for-new-macro (x) - "Set `kmacro-default-counter-format' to an existing keyboard macro's counter format. -This will apply to the next macro a user defines." - (let* ((actual-kmacro (cdr x)) - (format (nth 2 actual-kmacro))) - (kmacro-set-format format))) - -(defun counsel-kmacro-action-cycle-ring-to-macro (x) - "Cycle `kmacro-ring' until `last-kbd-macro' is the selected macro. -This is convenient when using \\[kmacro-end-or-call-macro] to call macros. -Note that cycling the ring changes the starting value of the current macro -to changes the current macro counter." - (let ((actual-kmacro (cdr x))) - (unless (equal last-kbd-macro - (if (listp last-kbd-macro) - last-kbd-macro - (car actual-kmacro))) - (while (not (equal actual-kmacro - (car kmacro-ring))) - (kmacro-cycle-ring-previous)) - ;; Once selected macro is at the head of the ring, - ;; cycle one last time. - (kmacro-cycle-ring-previous)))) - -(defun counsel-kmacro-action-set-saved-starting-counter (x) - "Set the starting counter value of the chosen macro. - -By default, sets to current value of the counter. It has no -effect when selecting the current macro. - -Normally, when cycling keyboard macro ring with \\[kmacro-cycle-ring-previous] -or \\[kmacro-cycle-ring-next], the current value of the macro counter is -included with the current macro definition. Then, when cycling -back, that counter value is restored. This function is meant to -achieve something similar when cycling macros in the context of -using `counsel-kmacro', which does not use different counter -values when running different macros." - (let ((actual-kmacro (cdr x)) - (default-kmacro-counter-string (number-to-string kmacro-counter))) - (setq kmacro-ring (mapcar (lambda (this-macro-in-ring) - (if (equal this-macro-in-ring actual-kmacro) - (list (car this-macro-in-ring) - (read-from-minibuffer (concat "Set initial counter for macro (default: " - default-kmacro-counter-string - "): ") - nil nil t nil - default-kmacro-counter-string) - (cl-caddr this-macro-in-ring)) - this-macro-in-ring)) - kmacro-ring)))) - -(defun counsel-kmacro-action-execute-after-prompt (x) - "Execute an existing keyboard macro, prompting for a starting counter value, a -counter format, and the number of times to execute the macro. - -If called with a prefix, will suggest that value for both the -counter value and iteration amount." - (let* ((default-string (if current-prefix-arg - (number-to-string current-prefix-arg) - nil)) - (actual-kmacro (cdr x)) - (kmacro-keys (nth 0 actual-kmacro)) - (kmacro-starting-counter (number-to-string (nth 1 actual-kmacro))) - (kmacro-starting-format (nth 2 actual-kmacro)) - (number-of-iterations - (read-from-minibuffer - (concat "Enter number of iterations for macro (default: " - (or default-string (number-to-string 2)) - "): ") - nil nil t nil - (or default-string (number-to-string 2)))) - (kmacro-initial-counter-value - (read-from-minibuffer - (concat "Enter a starting counter for macro (default: " - (or default-string kmacro-starting-counter) - "): ") - nil nil t nil - (or default-string kmacro-starting-counter))) - (kmacro-counter-format-start - (symbol-name (read-from-minibuffer - (concat "Enter format for macro counter (default: " - kmacro-starting-format - "): ") - nil nil t nil - kmacro-starting-format)))) - (kmacro-call-macro number-of-iterations t nil kmacro-keys))) - -(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 initial 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 "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 exec 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-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 (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-<F2>. -When ARG is non-nil, ignore NoDisplay property in *.desktop files." - (interactive "P") - (ivy-read "Run a command: " (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) - (mapc #'bury-buffer (cl-remove-if-not - #'buffer-live-p - counsel--switch-buffer-previous-buffers)) - (setq counsel--switch-buffer-temporary-buffers nil - counsel--switch-buffer-previous-buffers nil)) - -(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." - (and (fboundp 'project-current) - (cdr (project-current)))) - -(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) - "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.") - -;; This is loosely based on the Bash Make completion code -(defun counsel-compile--probe-make-targets (dir) - "Return a list of Make targets for DIR. - -Return an empty list is 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." - (let ((default-directory dir) - (targets nil)) - (with-temp-buffer - ;; 0 = no-rebuild, -q & 1 needs rebuild, 2 error (for GNUMake at - ;; least) - (when (< (call-process "make" nil t nil "-nqp") 2) - (goto-char (point-min)) - (while (re-search-forward counsel-compile-phony-pattern nil t) - (setq targets - (nconc targets (split-string - (match-string-no-properties 1))))))) - (sort 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 (srcdir &optional blddir) - "Return a list of Make targets for a given SRCDIR/BLDDIR combination. - -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) - (counsel-compile--probe-make-targets (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 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)) - (dirs (cl-remove-if-not #'cl-second files))) - ;; Any non-dir files? - (when (< (length dirs) - (length files)) - (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." - (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." - (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)))))) - -;;;###autoload -(defun counsel-compile (&optional dir) - "Call `compile' completing with smart suggestions, optionally for DIR." - (interactive) - (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 - :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-minor' -(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." - (delq nil - (mapcar - (lambda (mode) - (when (and (boundp mode) (commandp mode)) - (let ((lighter (cdr (assq mode minor-mode-alist)))) - (cons (concat - (if (symbol-value mode) "-" "+") - (symbol-name mode) - (propertize - (if lighter - (format " \"%s\"" - (format-mode-line (cons t lighter))) - "") - 'face font-lock-string-face)) - 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-minibuffer-map> - - \\[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-match "-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)) - -;;** `counsel-search' -(declare-function request "ext:request") - -(defcustom counsel-search-engine 'ddg - "The search engine choice in `counsel-search-engines-alist'." - :type '(choice - (const ddg) - (const google))) - -(defcustom counsel-search-engines-alist - '((google - "http://suggestqueries.google.com/complete/search" - "https://www.google.com/search?q=" - counsel--search-request-data-google) - (ddg - "https://duckduckgo.com/ac/" - "https://duckduckgo.com/html/?q=" - counsel--search-request-data-ddg)) - "Search engine parameters for `counsel-search'." - :type '(list)) - -(defun counsel--search-request-data-google (data) - (mapcar #'identity (aref data 1))) - -(defun counsel--search-request-data-ddg (data) - (mapcar #'cdar data)) - -(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 ((engine (cdr (assoc counsel-search-engine counsel-search-engines-alist)))) - (request - (nth 0 engine) - :type "GET" - :params (list - (cons "client" "firefox") - (cons "q" input)) - :parser 'json-read - :success (cl-function - (lambda (&key data &allow-other-keys) - (ivy-update-candidates - (funcall (nth 2 engine) data))))) - 0))) - -(defun counsel-search-action (x) - "Search for X." - (browse-url - (concat - (nth 2 (assoc counsel-search-engine counsel-search-engines-alist)) - x))) - -(defun counsel-search () - "Ivy interface for dynamically querying a search engine." - (interactive) - (require 'request) - (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 "<2019-10-17 Thu>") - -;;** `counsel-compilation-errors' -(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) - (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))) - (dolist (binding - '((execute-extended-command . counsel-M-x) - (describe-bindings . counsel-descbinds) - (describe-function . counsel-describe-function) - (describe-variable . counsel-describe-variable) - (describe-symbol . counsel-describe-symbol) - (apropos-command . counsel-apropos) - (describe-face . counsel-describe-face) - (list-faces-display . counsel-faces) - (find-file . counsel-find-file) - (find-library . counsel-find-library) - (imenu . counsel-imenu) - (load-library . counsel-load-library) - (load-theme . counsel-load-theme) - (yank-pop . counsel-yank-pop) - (info-lookup-symbol . counsel-info-lookup-symbol) - (pop-to-mark-command . counsel-mark-ring) - (geiser-doc-look-up-manual . counsel-geiser-doc-look-up-manual) - (bookmark-jump . counsel-bookmark))) - (define-key map (vector 'remap (car binding)) (cdr binding))) - map) - "Map for `counsel-mode'. -Remaps built-in 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 |