diff options
Diffstat (limited to 'elpa/counsel-20200706.1447/counsel.el')
| -rw-r--r-- | elpa/counsel-20200706.1447/counsel.el | 6850 |
1 files changed, 6850 insertions, 0 deletions
diff --git a/elpa/counsel-20200706.1447/counsel.el b/elpa/counsel-20200706.1447/counsel.el new file mode 100644 index 0000000..acd0972 --- /dev/null +++ b/elpa/counsel-20200706.1447/counsel.el @@ -0,0 +1,6850 @@ +;;; 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 |