Personal emacs config
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

6042 lines
226 KiB

  1. ;;; counsel.el --- Various completion functions using Ivy -*- lexical-binding: t -*-
  2. ;; Copyright (C) 2015-2019 Free Software Foundation, Inc.
  3. ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
  4. ;; URL: https://github.com/abo-abo/swiper
  5. ;; Package-Version: 0.13.0
  6. ;; Package-Commit: cd634c6f51458f81898ecf2821ac3169cb65a1eb
  7. ;; Version: 0.13.0
  8. ;; Package-Requires: ((emacs "24.5") (swiper "0.13.0"))
  9. ;; Keywords: convenience, matching, tools
  10. ;; This file is part of GNU Emacs.
  11. ;; This file is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 3, or (at your option)
  14. ;; any later version.
  15. ;; This program is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  18. ;; GNU General Public License for more details.
  19. ;; For a full copy of the GNU General Public License
  20. ;; see <https://www.gnu.org/licenses/>.
  21. ;;; Commentary:
  22. ;; Just call one of the interactive functions in this file to complete
  23. ;; the corresponding thing using `ivy'.
  24. ;;
  25. ;; Currently available:
  26. ;; - Symbol completion for Elisp, Common Lisp, Python, Clojure, C, C++.
  27. ;; - Describe functions for Elisp: function, variable, library, command,
  28. ;; bindings, theme.
  29. ;; - Navigation functions: imenu, ace-line, semantic, outline.
  30. ;; - Git utilities: git-files, git-grep, git-log, git-stash, git-checkout.
  31. ;; - Grep utilities: grep, ag, pt, recoll, ack, rg.
  32. ;; - System utilities: process list, rhythmbox, linux-app.
  33. ;; - Many more.
  34. ;;; Code:
  35. (require 'swiper)
  36. (require 'compile)
  37. (require 'dired)
  38. (defgroup counsel nil
  39. "Completion functions using Ivy."
  40. :group 'matching
  41. :prefix "counsel-")
  42. ;;* Utility
  43. (defun counsel--elisp-to-pcre (regex &optional look-around)
  44. "Convert REGEX from Elisp format to PCRE format, on best-effort basis.
  45. REGEX may be of any format returned by an Ivy regex function,
  46. namely a string or a list. The return value is always a string.
  47. Note that incorrect results may be returned for sufficiently
  48. complex regexes."
  49. (if (consp regex)
  50. (if (and look-around
  51. (or (cdr regex)
  52. (not (cdar regex))))
  53. (concat
  54. "^"
  55. (mapconcat
  56. (lambda (pair)
  57. (let ((subexp (counsel--elisp-to-pcre (car pair))))
  58. (format "(?%c.*%s)"
  59. (if (cdr pair) ?= ?!)
  60. subexp)))
  61. regex
  62. ""))
  63. (mapconcat
  64. (lambda (pair)
  65. (let ((subexp (counsel--elisp-to-pcre (car pair))))
  66. (if (string-match-p "|" subexp)
  67. (format "(?:%s)" subexp)
  68. subexp)))
  69. (cl-remove-if-not #'cdr regex)
  70. ".*"))
  71. (replace-regexp-in-string
  72. "\\\\[(){}|`']\\|[()]"
  73. (lambda (s)
  74. (or (cdr (assoc s '(("\\(" . "(")
  75. ("\\)" . ")")
  76. ("(" . "\\(")
  77. (")" . "\\)")
  78. ("\\{" . "{")
  79. ("\\}" . "}")
  80. ("\\|" . "|")
  81. ("\\`" . "^")
  82. ("\\'" . "$"))))
  83. (error
  84. "Unexpected error in `counsel--elisp-to-pcre' (got match %S)" s)))
  85. regex t t)))
  86. (defun counsel-directory-name (dir)
  87. "Return the name of directory DIR with a slash."
  88. (file-name-as-directory
  89. (file-name-nondirectory
  90. (directory-file-name dir))))
  91. (defun counsel-string-compose (prefix str)
  92. "Make PREFIX the display prefix of STR through text properties."
  93. (let ((str (copy-sequence str)))
  94. (put-text-property
  95. 0 1 'display
  96. (concat prefix (substring str 0 1))
  97. str)
  98. str))
  99. (defun counsel-require-program (cmd)
  100. "Check system for program used in CMD, printing error if not found.
  101. CMD is either a string or a list of strings.
  102. To skip the `executable-find' check, start the string with a space."
  103. (unless (and (stringp cmd) (string-match-p "^ " cmd))
  104. (let ((program (if (listp cmd)
  105. (car cmd)
  106. (car (split-string cmd)))))
  107. (or (and (stringp program)
  108. (not (string= program ""))
  109. (executable-find program))
  110. (user-error "Required program \"%s\" not found in your path" program)))))
  111. (declare-function eshell-split-path "esh-util")
  112. (defun counsel-prompt-function-dir ()
  113. "Return prompt appended with the parent directory."
  114. (require 'esh-util)
  115. (let* ((dir (ivy-state-directory ivy-last))
  116. (parts (nthcdr 3 (eshell-split-path dir)))
  117. (dir (format " [%s]: " (if parts (apply #'concat "..." parts) dir))))
  118. (ivy-add-prompt-count
  119. (replace-regexp-in-string ; Insert dir before any trailing colon.
  120. "\\(?:: ?\\)?\\'" dir (ivy-state-prompt ivy-last) t t))))
  121. ;;* Async Utility
  122. (defvar counsel--async-time nil
  123. "Store the time when a new process was started.
  124. Or the time of the last minibuffer update.")
  125. (defvar counsel--async-start nil
  126. "Store the time when a new process was started.
  127. Or the time of the last minibuffer update.")
  128. (defvar counsel--async-duration nil
  129. "Store the time a process takes to gather all its candidates.
  130. The time is measured in seconds.")
  131. (defvar counsel--async-exit-code-plist ()
  132. "Associate commands with their exit code descriptions.
  133. This plist maps commands to a plist mapping their exit codes to
  134. descriptions.")
  135. (defvar counsel--async-last-error-string nil
  136. "When the process returned non-0, store the output here.")
  137. (defun counsel-set-async-exit-code (cmd number str)
  138. "For CMD, associate NUMBER exit code with STR."
  139. (let ((plist (plist-get counsel--async-exit-code-plist cmd)))
  140. (setq counsel--async-exit-code-plist
  141. (plist-put counsel--async-exit-code-plist
  142. cmd
  143. (plist-put plist number str)))))
  144. (defvar counsel-async-split-string-re-alist '((t . "\n"))
  145. "Store the regexp for splitting shell command output.")
  146. (defvar counsel-async-ignore-re-alist nil
  147. "An alist of regexp matching candidates to ignore in `counsel--async-filter'.")
  148. (defvar counsel--async-last-command nil
  149. "Store the last command ran by `counsel--async-command'.")
  150. (defun counsel--async-command (cmd &optional sentinel filter name)
  151. "Start and return new counsel process by calling CMD.
  152. CMD can be either a shell command as a string, or a list of the
  153. program name to be called directly, followed by its arguments.
  154. If the default counsel process or one with NAME already exists,
  155. kill it and its associated buffer before starting a new one.
  156. Give the process the functions SENTINEL and FILTER, which default
  157. to `counsel--async-sentinel' and `counsel--async-filter',
  158. respectively."
  159. (counsel-delete-process name)
  160. (setq name (or name " *counsel*"))
  161. (when (get-buffer name)
  162. (kill-buffer name))
  163. (setq counsel--async-last-command cmd)
  164. (let* ((buf (get-buffer-create name))
  165. (proc (if (listp cmd)
  166. (apply #'start-file-process name buf cmd)
  167. (start-file-process-shell-command name buf cmd))))
  168. (setq counsel--async-time (current-time))
  169. (setq counsel--async-start counsel--async-time)
  170. (set-process-sentinel proc (or sentinel #'counsel--async-sentinel))
  171. (set-process-filter proc (or filter #'counsel--async-filter))
  172. proc))
  173. (defun counsel--split-string (&optional str)
  174. (split-string
  175. (or str (buffer-string))
  176. (ivy-alist-setting counsel-async-split-string-re-alist)
  177. t))
  178. (defun counsel--async-sentinel (process _msg)
  179. "Sentinel function for an asynchronous counsel PROCESS."
  180. (when (eq (process-status process) 'exit)
  181. (if (zerop (process-exit-status process))
  182. (progn
  183. (ivy--set-candidates
  184. (ivy--sort-maybe
  185. (with-current-buffer (process-buffer process)
  186. (counsel--split-string))))
  187. (when counsel--async-start
  188. (setq counsel--async-duration
  189. (time-to-seconds (time-since counsel--async-start))))
  190. (let ((re (ivy-re-to-str (funcall ivy--regex-function ivy-text))))
  191. (if ivy--old-cands
  192. (if (eq (ivy-alist-setting ivy-index-functions-alist) 'ivy-recompute-index-zero)
  193. (ivy-set-index 0)
  194. (ivy--recompute-index ivy-text re ivy--all-candidates))
  195. (unless (ivy-set-index
  196. (ivy--preselect-index
  197. (ivy-state-preselect ivy-last)
  198. ivy--all-candidates))
  199. (ivy--recompute-index ivy-text re ivy--all-candidates))))
  200. (setq ivy--old-cands ivy--all-candidates)
  201. (if ivy--all-candidates
  202. (ivy--exhibit)
  203. (ivy--insert-minibuffer "")))
  204. (setq counsel--async-last-error-string
  205. (with-current-buffer (process-buffer process) (buffer-string)))
  206. (setq ivy--all-candidates
  207. (let ((status (process-exit-status process))
  208. (plist (plist-get counsel--async-exit-code-plist
  209. (ivy-state-caller ivy-last))))
  210. (list (or (plist-get plist status)
  211. (format "error code %d" status)))))
  212. (setq ivy--old-cands ivy--all-candidates)
  213. (ivy--exhibit))))
  214. (defcustom counsel-async-filter-update-time 500000
  215. "The amount of microseconds to wait until updating `counsel--async-filter'."
  216. :type 'integer)
  217. (defun counsel--async-filter (process str)
  218. "Receive from PROCESS the output STR.
  219. Update the minibuffer with the amount of lines collected every
  220. `counsel-async-filter-update-time' microseconds since the last update."
  221. (with-current-buffer (process-buffer process)
  222. (insert str))
  223. (when (time-less-p (list 0 0 counsel-async-filter-update-time)
  224. (time-since counsel--async-time))
  225. (let (numlines)
  226. (with-current-buffer (process-buffer process)
  227. (setq numlines (count-lines (point-min) (point-max)))
  228. (ivy--set-candidates
  229. (let ((lines (counsel--split-string))
  230. (ignore-re (ivy-alist-setting counsel-async-ignore-re-alist)))
  231. (if (stringp ignore-re)
  232. (cl-remove-if (lambda (line)
  233. (string-match-p ignore-re line))
  234. lines)
  235. lines))))
  236. (let ((ivy--prompt (format "%d++ %s" numlines (ivy-state-prompt ivy-last))))
  237. (ivy--insert-minibuffer (ivy--format ivy--all-candidates)))
  238. (setq counsel--async-time (current-time)))))
  239. (defun counsel-delete-process (&optional name)
  240. "Delete current counsel process or that with NAME."
  241. (let ((process (get-process (or name " *counsel*"))))
  242. (when process
  243. (delete-process process))))
  244. ;;* Completion at point
  245. ;;** `counsel-el'
  246. ;;;###autoload
  247. (defun counsel-el ()
  248. "Elisp completion at point."
  249. (interactive)
  250. (let* ((bnd (unless (and (looking-at ")")
  251. (eq (char-before) ?\())
  252. (bounds-of-thing-at-point 'symbol)))
  253. (str (if bnd
  254. (buffer-substring-no-properties
  255. (car bnd)
  256. (cdr bnd))
  257. ""))
  258. (pred (and (eq (char-before (car bnd)) ?\()
  259. #'fboundp))
  260. symbol-names)
  261. (setq ivy-completion-beg (car bnd))
  262. (setq ivy-completion-end (cdr bnd))
  263. (if (string= str "")
  264. (mapatoms
  265. (lambda (x)
  266. (when (and (symbolp x) (funcall pred x))
  267. (push (symbol-name x) symbol-names))))
  268. (setq symbol-names (all-completions str obarray pred)))
  269. (ivy-read "Symbol name: " symbol-names
  270. :initial-input str
  271. :action #'ivy-completion-in-region-action
  272. :caller 'counsel-el)))
  273. (ivy-configure 'counsel-el
  274. :height 7)
  275. ;;** `counsel-cl'
  276. (declare-function slime-symbol-start-pos "ext:slime")
  277. (declare-function slime-symbol-end-pos "ext:slime")
  278. (declare-function slime-contextual-completions "ext:slime-c-p-c")
  279. ;;;###autoload
  280. (defun counsel-cl ()
  281. "Common Lisp completion at point."
  282. (interactive)
  283. (setq ivy-completion-beg (slime-symbol-start-pos))
  284. (setq ivy-completion-end (slime-symbol-end-pos))
  285. (ivy-read "Symbol name: "
  286. (car (slime-contextual-completions
  287. ivy-completion-beg
  288. ivy-completion-end))
  289. :action #'ivy-completion-in-region-action))
  290. ;;** `counsel-jedi'
  291. (declare-function deferred:sync! "ext:deferred")
  292. (declare-function jedi:complete-request "ext:jedi-core")
  293. (declare-function jedi:ac-direct-matches "ext:jedi")
  294. ;;;###autoload
  295. (defun counsel-jedi ()
  296. "Python completion at point."
  297. (interactive)
  298. (let ((bnd (bounds-of-thing-at-point 'symbol)))
  299. (setq ivy-completion-beg (car bnd))
  300. (setq ivy-completion-end (cdr bnd)))
  301. (deferred:sync!
  302. (jedi:complete-request))
  303. (ivy-read "Symbol name: " (jedi:ac-direct-matches)
  304. :action #'counsel--py-action))
  305. (defun counsel--py-action (symbol-name)
  306. "Insert SYMBOL-NAME, erasing the previous one."
  307. (when (stringp symbol-name)
  308. (with-ivy-window
  309. (when ivy-completion-beg
  310. (delete-region
  311. ivy-completion-beg
  312. ivy-completion-end))
  313. (setq ivy-completion-beg (point))
  314. (insert symbol-name)
  315. (setq ivy-completion-end (point)))))
  316. ;;** `counsel-clj'
  317. (declare-function cider-sync-request:complete "ext:cider-client")
  318. (defun counsel--generic (completion-fn)
  319. "Complete thing at point with COMPLETION-FN."
  320. (let* ((bnd (or (bounds-of-thing-at-point 'symbol)
  321. (cons (point) (point))))
  322. (str (buffer-substring-no-properties
  323. (car bnd) (cdr bnd)))
  324. (candidates (funcall completion-fn str))
  325. (res (ivy-read (format "pattern (%s): " str)
  326. candidates
  327. :caller 'counsel--generic)))
  328. (when (stringp res)
  329. (when bnd
  330. (delete-region (car bnd) (cdr bnd)))
  331. (insert res))))
  332. (ivy-configure 'counsel--generic
  333. :height 7)
  334. ;;;###autoload
  335. (defun counsel-clj ()
  336. "Clojure completion at point."
  337. (interactive)
  338. (counsel--generic
  339. (lambda (str)
  340. (mapcar
  341. #'cl-caddr
  342. (cider-sync-request:complete str ":same")))))
  343. ;;** `counsel-company'
  344. (defvar company-candidates)
  345. (defvar company-common)
  346. (defvar company-prefix)
  347. (declare-function company-abort "ext:company")
  348. (declare-function company-complete "ext:company")
  349. (declare-function company-mode "ext:company")
  350. ;;;###autoload
  351. (defun counsel-company ()
  352. "Complete using `company-candidates'."
  353. (interactive)
  354. (company-mode 1)
  355. (unless company-candidates
  356. (company-complete))
  357. (let ((len (cond (company-common
  358. (length company-common))
  359. (company-prefix
  360. (length company-prefix)))))
  361. (when len
  362. (setq ivy-completion-beg (- (point) len))
  363. (setq ivy-completion-end (point))
  364. (ivy-read "Candidate: " company-candidates
  365. :action #'ivy-completion-in-region-action
  366. :caller 'counsel-company))))
  367. (ivy-configure 'counsel-company
  368. :unwind-fn #'company-abort)
  369. ;;** `counsel-irony'
  370. (declare-function irony-completion-candidates-async "ext:irony-completion")
  371. (declare-function irony-completion-symbol-bounds "ext:irony-completion")
  372. (declare-function irony-completion-annotation "ext:irony-completion")
  373. ;;;###autoload
  374. (defun counsel-irony ()
  375. "Inline C/C++ completion using Irony."
  376. (interactive)
  377. (irony-completion-candidates-async 'counsel-irony-callback))
  378. (defun counsel-irony-callback (candidates)
  379. "Callback function for Irony to search among CANDIDATES."
  380. (interactive)
  381. (let* ((symbol-bounds (irony-completion-symbol-bounds))
  382. (beg (car symbol-bounds))
  383. (end (cdr symbol-bounds))
  384. (prefix (buffer-substring-no-properties beg end)))
  385. (setq ivy-completion-beg beg
  386. ivy-completion-end end)
  387. (ivy-read "code: " (mapcar #'counsel-irony-annotate candidates)
  388. :predicate (lambda (candidate)
  389. (string-prefix-p prefix (car candidate)))
  390. :caller 'counsel-irony
  391. :action #'ivy-completion-in-region-action)))
  392. (defun counsel-irony-annotate (x)
  393. "Make Ivy candidate from Irony candidate X."
  394. (cons (concat (car x) (irony-completion-annotation x))
  395. (car x)))
  396. (add-to-list 'ivy-display-functions-alist '(counsel-irony . ivy-display-function-overlay))
  397. ;;* Elisp symbols
  398. ;;** `counsel-describe-variable'
  399. (defvar counsel-describe-map
  400. (let ((map (make-sparse-keymap)))
  401. (define-key map (kbd "C-.") #'counsel-find-symbol)
  402. (define-key map (kbd "C-,") #'counsel--info-lookup-symbol)
  403. map))
  404. (ivy-set-actions
  405. 'counsel-describe-variable
  406. '(("I" counsel-info-lookup-symbol "info")
  407. ("d" counsel--find-symbol "definition")))
  408. (defvar counsel-describe-symbol-history ()
  409. "History list for variable and function names.
  410. Used by commands `counsel-describe-variable' and
  411. `counsel-describe-function'.")
  412. (defun counsel-find-symbol ()
  413. "Jump to the definition of the current symbol."
  414. (interactive)
  415. (ivy-exit-with-action #'counsel--find-symbol))
  416. (put 'counsel-find-symbol 'no-counsel-M-x t)
  417. (defun counsel--info-lookup-symbol ()
  418. "Lookup the current symbol in the info docs."
  419. (interactive)
  420. (ivy-exit-with-action #'counsel-info-lookup-symbol))
  421. (defvar find-tag-marker-ring)
  422. (declare-function xref-push-marker-stack "xref")
  423. (defalias 'counsel--push-xref-marker
  424. (if (require 'xref nil t)
  425. #'xref-push-marker-stack
  426. (require 'etags)
  427. (lambda (&optional m)
  428. (ring-insert (with-no-warnings find-tag-marker-ring) (or m (point-marker)))))
  429. "Compatibility shim for `xref-push-marker-stack'.")
  430. (defun counsel--find-symbol (x)
  431. "Find symbol definition that corresponds to string X."
  432. (with-ivy-window
  433. (counsel--push-xref-marker)
  434. (let ((full-name (get-text-property 0 'full-name x)))
  435. (if full-name
  436. (find-library full-name)
  437. (let ((sym (read x)))
  438. (cond ((and (eq (ivy-state-caller ivy-last)
  439. 'counsel-describe-variable)
  440. (boundp sym))
  441. (find-variable sym))
  442. ((fboundp sym)
  443. (find-function sym))
  444. ((boundp sym)
  445. (find-variable sym))
  446. ((or (featurep sym)
  447. (locate-library
  448. (prin1-to-string sym)))
  449. (find-library
  450. (prin1-to-string sym)))
  451. (t
  452. (error "Couldn't find definition of %s"
  453. sym))))))))
  454. (defun counsel--variable-p (symbol)
  455. "Return non-nil if SYMBOL is a bound or documented variable."
  456. (or (and (boundp symbol)
  457. (not (keywordp symbol)))
  458. (get symbol 'variable-documentation)))
  459. (defcustom counsel-describe-variable-function #'describe-variable
  460. "Function to call to describe a variable passed as parameter."
  461. :type 'function)
  462. (defun counsel-describe-variable-transformer (var)
  463. "Propertize VAR if it's a custom variable."
  464. (if (custom-variable-p (intern var))
  465. (ivy-append-face var 'ivy-highlight-face)
  466. var))
  467. ;;;###autoload
  468. (defun counsel-describe-variable ()
  469. "Forward to `describe-variable'.
  470. Variables declared using `defcustom' are highlighted according to
  471. `ivy-highlight-face'."
  472. (interactive)
  473. (let ((enable-recursive-minibuffers t))
  474. (ivy-read "Describe variable: " obarray
  475. :predicate #'counsel--variable-p
  476. :require-match t
  477. :history 'counsel-describe-symbol-history
  478. :keymap counsel-describe-map
  479. :preselect (ivy-thing-at-point)
  480. :action (lambda (x)
  481. (funcall counsel-describe-variable-function (intern x)))
  482. :caller 'counsel-describe-variable)))
  483. (ivy-configure 'counsel-describe-variable
  484. :initial-input "^"
  485. :display-transformer-fn #'counsel-describe-variable-transformer
  486. :sort-fn #'ivy-string<)
  487. ;;** `counsel-describe-function'
  488. (ivy-set-actions
  489. 'counsel-describe-function
  490. '(("I" counsel-info-lookup-symbol "info")
  491. ("d" counsel--find-symbol "definition")))
  492. (defcustom counsel-describe-function-function #'describe-function
  493. "Function to call to describe a function passed as parameter."
  494. :type 'function)
  495. (defun counsel-describe-function-transformer (function-name)
  496. "Propertize FUNCTION-NAME if it's an interactive function."
  497. (if (commandp (intern function-name))
  498. (ivy-append-face function-name 'ivy-highlight-face)
  499. function-name))
  500. (defun ivy-function-called-at-point ()
  501. (let ((f (function-called-at-point)))
  502. (and f (symbol-name f))))
  503. (defcustom counsel-describe-function-preselect #'ivy-thing-at-point
  504. "Determine what `counsel-describe-function' should preselect."
  505. :type '(radio
  506. (function-item ivy-thing-at-point)
  507. (function-item ivy-function-called-at-point)))
  508. ;;;###autoload
  509. (defun counsel-describe-function ()
  510. "Forward to `describe-function'.
  511. Interactive functions (i.e., commands) are highlighted according
  512. to `ivy-highlight-face'."
  513. (interactive)
  514. (let ((enable-recursive-minibuffers t))
  515. (ivy-read "Describe function: " obarray
  516. :predicate (lambda (sym)
  517. (or (fboundp sym)
  518. (get sym 'function-documentation)))
  519. :require-match t
  520. :history 'counsel-describe-symbol-history
  521. :keymap counsel-describe-map
  522. :preselect (funcall counsel-describe-function-preselect)
  523. :action (lambda (x)
  524. (funcall counsel-describe-function-function (intern x)))
  525. :caller 'counsel-describe-function)))
  526. (ivy-configure 'counsel-describe-function
  527. :initial-input "^"
  528. :display-transformer-fn #'counsel-describe-function-transformer
  529. :sort-fn #'ivy-string<)
  530. ;;** `counsel-set-variable'
  531. (defvar counsel-set-variable-history nil
  532. "Store history for `counsel-set-variable'.")
  533. (defun counsel-read-setq-expression (sym)
  534. "Read and eval a setq expression for SYM."
  535. (setq this-command 'eval-expression)
  536. (let* ((minibuffer-completing-symbol t)
  537. (sym-value (symbol-value sym))
  538. (expr (minibuffer-with-setup-hook
  539. (lambda ()
  540. (add-function :before-until (local 'eldoc-documentation-function)
  541. #'elisp-eldoc-documentation-function)
  542. (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil t)
  543. (run-hooks 'eval-expression-minibuffer-setup-hook)
  544. (goto-char (minibuffer-prompt-end))
  545. (forward-char 6)
  546. (insert (format "%S " sym)))
  547. (read-from-minibuffer "Eval: "
  548. (format
  549. (if (and sym-value (consp sym-value))
  550. "(setq '%S)"
  551. "(setq %S)")
  552. sym-value)
  553. read-expression-map t
  554. 'read-expression-history))))
  555. (eval-expression expr)))
  556. (defun counsel--setq-doconst (x)
  557. "Return a cons of description and value for X.
  558. X is an item of a radio- or choice-type defcustom."
  559. (when (listp x)
  560. (let ((v (car-safe (last x)))
  561. (tag (and (eq (car x) 'const)
  562. (plist-get (cdr x) :tag))))
  563. (when (and (or v tag) (not (eq v 'function)))
  564. (cons
  565. (concat
  566. (when tag
  567. (concat tag ": "))
  568. (if (stringp v) v (prin1-to-string v)))
  569. (if (symbolp v)
  570. (list 'quote v)
  571. v))))))
  572. (declare-function lv-message "ext:lv")
  573. (declare-function lv-delete-window "ext:lv")
  574. (declare-function custom-variable-documentation "cus-edit")
  575. (defface counsel-variable-documentation
  576. '((t :inherit font-lock-comment-face))
  577. "Face for displaying Lisp documentation."
  578. :group 'ivy-faces)
  579. ;;;###autoload
  580. (defun counsel-set-variable (sym)
  581. "Set a variable SYM, with completion.
  582. When the selected variable is a `defcustom' with the type boolean
  583. or radio, offer completion of all possible values.
  584. Otherwise, offer a variant of `eval-expression', with the initial
  585. input corresponding to the chosen variable.
  586. With a prefix arg, restrict list to variables defined using
  587. `defcustom'."
  588. (interactive (list (intern
  589. (ivy-read "Set variable: " obarray
  590. :predicate (if current-prefix-arg
  591. #'custom-variable-p
  592. #'counsel--variable-p)
  593. :history 'counsel-set-variable-history
  594. :preselect (ivy-thing-at-point)))))
  595. (let ((doc (and (require 'cus-edit)
  596. (require 'lv nil t)
  597. (not (string= "nil" (custom-variable-documentation sym)))
  598. (propertize (custom-variable-documentation sym)
  599. 'face 'counsel-variable-documentation)))
  600. sym-type
  601. cands)
  602. (unwind-protect
  603. (progn
  604. (when doc
  605. (lv-message (ivy--quote-format-string doc)))
  606. (if (and (boundp sym)
  607. (setq sym-type (get sym 'custom-type))
  608. (cond
  609. ((and (consp sym-type)
  610. (memq (car sym-type) '(choice radio)))
  611. (setq cands (delq nil (mapcar #'counsel--setq-doconst
  612. (cdr sym-type)))))
  613. ((eq sym-type 'boolean)
  614. (setq cands '(("nil" . nil) ("t" . t))))
  615. (t nil)))
  616. (let* ((sym-val (symbol-value sym))
  617. (res (ivy-read (format "Set (%S <%s>): " sym sym-val)
  618. cands
  619. :preselect (prin1-to-string sym-val))))
  620. (when res
  621. (setq res
  622. (if (assoc res cands)
  623. (cdr (assoc res cands))
  624. (read res)))
  625. (set sym (if (and (listp res) (eq (car res) 'quote))
  626. (cadr res)
  627. res))))
  628. (unless (boundp sym)
  629. (set sym nil))
  630. (counsel-read-setq-expression sym)))
  631. (when doc
  632. (lv-delete-window)))))
  633. ;;** `counsel-apropos'
  634. ;;;###autoload
  635. (defun counsel-apropos ()
  636. "Show all matching symbols.
  637. See `apropos' for further information on what is considered
  638. a symbol and how to search for them."
  639. (interactive)
  640. (ivy-read "Search for symbol (word list or regexp): " obarray
  641. :predicate (lambda (sym)
  642. (or (fboundp sym)
  643. (boundp sym)
  644. (facep sym)
  645. (symbol-plist sym)))
  646. :history 'counsel-apropos-history
  647. :preselect (ivy-thing-at-point)
  648. :action (lambda (pattern)
  649. (when (string= pattern "")
  650. (user-error "Please specify a pattern"))
  651. ;; If the user selected a candidate form the list, we use
  652. ;; a pattern which matches only the selected symbol.
  653. (if (memq this-command '(ivy-immediate-done ivy-alt-done))
  654. ;; Regexp pattern are passed verbatim, other input is
  655. ;; split into words.
  656. (if (string= (regexp-quote pattern) pattern)
  657. (apropos (split-string pattern "[ \t]+" t))
  658. (apropos pattern))
  659. (apropos (concat "\\`" pattern "\\'"))))
  660. :caller 'counsel-apropos))
  661. (ivy-configure 'counsel-apropos
  662. :sort-fn #'ivy-string<)
  663. ;;** `counsel-info-lookup-symbol'
  664. (defvar info-lookup-mode)
  665. (declare-function info-lookup-guess-default "info-look")
  666. (declare-function info-lookup->completions "info-look")
  667. (declare-function info-lookup->mode-value "info-look")
  668. (declare-function info-lookup-select-mode "info-look")
  669. (declare-function info-lookup-change-mode "info-look")
  670. (declare-function info-lookup "info-look")
  671. ;;;###autoload
  672. (defun counsel-info-lookup-symbol (symbol &optional mode)
  673. "Forward SYMBOL to `info-lookup-symbol' with ivy completion.
  674. With prefix arg MODE a query for the symbol help mode is offered."
  675. (interactive
  676. (progn
  677. (require 'info-look)
  678. ;; Courtesy of `info-lookup-interactive-arguments'
  679. (let* ((topic 'symbol)
  680. (mode (cond (current-prefix-arg
  681. (info-lookup-change-mode topic))
  682. ((info-lookup->mode-value
  683. topic (info-lookup-select-mode))
  684. info-lookup-mode)
  685. ((info-lookup-change-mode topic))))
  686. (enable-recursive-minibuffers t))
  687. (list (ivy-read "Describe symbol: " (info-lookup->completions topic mode)
  688. :history 'info-lookup-history
  689. :preselect (info-lookup-guess-default topic mode)
  690. :caller 'counsel-info-lookup-symbol)
  691. mode))))
  692. (info-lookup-symbol symbol mode))
  693. (ivy-configure 'counsel-info-lookup-symbol
  694. :sort-fn #'ivy-string<)
  695. ;;** `counsel-M-x'
  696. (defface counsel-key-binding
  697. '((t :inherit font-lock-keyword-face))
  698. "Face used by `counsel-M-x' for key bindings."
  699. :group 'ivy-faces)
  700. (defface counsel-active-mode
  701. '((t :inherit font-lock-builtin-face))
  702. "Face used by `counsel-M-x' for activated modes."
  703. :group 'ivy-faces)
  704. (defcustom counsel-alias-expand t
  705. "When non-nil, show the expansion of aliases in `counsel-M-x'."
  706. :type 'boolean
  707. :group 'ivy)
  708. (defun counsel-M-x-transformer (cmd)
  709. "Return CMD annotated with its active key binding, if any."
  710. (let* ((sym (intern cmd))
  711. (alias (symbol-function sym))
  712. (key (where-is-internal sym nil t)))
  713. (when (or (eq sym major-mode)
  714. (and
  715. (memq sym minor-mode-list)
  716. (boundp sym)
  717. (buffer-local-value sym (ivy-state-buffer ivy-last))))
  718. (setq cmd (propertize cmd 'face 'counsel-active-mode)))
  719. (concat cmd
  720. (when (and (symbolp alias) counsel-alias-expand)
  721. (format " (%s)" alias))
  722. (when key
  723. ;; Prefer `<f2>' over `C-x 6' where applicable
  724. (let ((i (cl-search [?\C-x ?6] key)))
  725. (when i
  726. (let ((dup (vconcat (substring key 0 i) [f2] (substring key (+ i 2))))
  727. (map (current-global-map)))
  728. (when (equal (lookup-key map key)
  729. (lookup-key map dup))
  730. (setq key dup)))))
  731. (setq key (key-description key))
  732. (put-text-property 0 (length key) 'face 'counsel-key-binding key)
  733. (format " (%s)" key)))))
  734. (defvar amx-initialized)
  735. (defvar amx-cache)
  736. (declare-function amx-initialize "ext:amx")
  737. (declare-function amx-detect-new-commands "ext:amx")
  738. (declare-function amx-update "ext:amx")
  739. (declare-function amx-rank "ext:amx")
  740. (defvar smex-initialized-p)
  741. (defvar smex-ido-cache)
  742. (declare-function smex-initialize "ext:smex")
  743. (declare-function smex-detect-new-commands "ext:smex")
  744. (declare-function smex-update "ext:smex")
  745. (declare-function smex-rank "ext:smex")
  746. (defun counsel--M-x-externs ()
  747. "Return `counsel-M-x' candidates from external packages.
  748. The return value is a list of strings. The currently supported
  749. packages are, in order of precedence, `amx' and `smex'."
  750. (cond ((require 'amx nil t)
  751. (unless amx-initialized
  752. (amx-initialize))
  753. (when (amx-detect-new-commands)
  754. (amx-update))
  755. (mapcar (lambda (entry)
  756. (symbol-name (car entry)))
  757. amx-cache))
  758. ((require 'smex nil t)
  759. (unless smex-initialized-p
  760. (smex-initialize))
  761. (when (smex-detect-new-commands)
  762. (smex-update))
  763. smex-ido-cache)))
  764. (defun counsel--M-x-prompt ()
  765. "String for `M-x' plus the string representation of `current-prefix-arg'."
  766. (concat (cond ((null current-prefix-arg)
  767. nil)
  768. ((eq current-prefix-arg '-)
  769. "- ")
  770. ((integerp current-prefix-arg)
  771. (format "%d " current-prefix-arg))
  772. ((= (car current-prefix-arg) 4)
  773. "C-u ")
  774. (t
  775. (format "%d " (car current-prefix-arg))))
  776. "M-x "))
  777. (defvar counsel-M-x-history nil
  778. "History for `counsel-M-x'.")
  779. (defun counsel-M-x-action (cmd)
  780. "Execute CMD."
  781. (setq cmd (intern cmd))
  782. (cond ((bound-and-true-p amx-initialized)
  783. (amx-rank cmd))
  784. ((bound-and-true-p smex-initialized-p)
  785. (smex-rank cmd)))
  786. (setq prefix-arg current-prefix-arg)
  787. (setq this-command cmd)
  788. (setq real-this-command cmd)
  789. (command-execute cmd 'record))
  790. ;;;###autoload
  791. (defun counsel-M-x (&optional initial-input)
  792. "Ivy version of `execute-extended-command'.
  793. Optional INITIAL-INPUT is the initial input in the minibuffer.
  794. This function integrates with either the `amx' or `smex' package
  795. when available, in that order of precedence."
  796. (interactive)
  797. ;; When `counsel-M-x' returns, `last-command' would be set to
  798. ;; `counsel-M-x' because :action hasn't been invoked yet.
  799. ;; Instead, preserve the old value of `this-command'.
  800. (setq this-command last-command)
  801. (setq real-this-command real-last-command)
  802. (let ((externs (counsel--M-x-externs)))
  803. (ivy-read (counsel--M-x-prompt) (or externs obarray)
  804. :predicate (if externs
  805. (lambda (x)
  806. (not (get (intern x) 'no-counsel-M-x)))
  807. (lambda (sym)
  808. (and (commandp sym)
  809. (not (get sym 'byte-obsolete-info))
  810. (not (get sym 'no-counsel-M-x)))))
  811. :require-match t
  812. :history 'counsel-M-x-history
  813. :action #'counsel-M-x-action
  814. :keymap counsel-describe-map
  815. :initial-input initial-input
  816. :caller 'counsel-M-x)))
  817. (ivy-configure 'counsel-M-x
  818. :initial-input "^"
  819. :display-transformer-fn #'counsel-M-x-transformer)
  820. (ivy-set-actions
  821. 'counsel-M-x
  822. `(("d" counsel--find-symbol "definition")
  823. ("h" ,(lambda (x) (funcall counsel-describe-function-function (intern x))) "help")))
  824. ;;** `counsel-command-history'
  825. (defun counsel-command-history-action-eval (cmd)
  826. "Eval the command CMD."
  827. (eval (read cmd)))
  828. (defun counsel-command-history-action-edit-and-eval (cmd)
  829. "Edit and eval the command CMD."
  830. (edit-and-eval-command "Eval: " (read cmd)))
  831. (ivy-set-actions
  832. 'counsel-command-history
  833. '(("r" counsel-command-history-action-eval "eval command")
  834. ("e" counsel-command-history-action-edit-and-eval "edit and eval command")))
  835. ;;;###autoload
  836. (defun counsel-command-history ()
  837. "Show the history of commands."
  838. (interactive)
  839. (ivy-read "Command: " (mapcar #'prin1-to-string command-history)
  840. :require-match t
  841. :action #'counsel-command-history-action-eval
  842. :caller 'counsel-command-history))
  843. ;;** `counsel-load-library'
  844. (defun counsel-library-candidates ()
  845. "Return a list of completion candidates for `counsel-load-library'."
  846. (let ((suffix (concat (regexp-opt '(".el" ".el.gz") t) "\\'"))
  847. (cands (make-hash-table :test #'equal))
  848. short-name
  849. old-val
  850. dir-parent
  851. res)
  852. (dolist (dir load-path)
  853. (setq dir (or dir default-directory)) ;; interpret nil in load-path as default-directory
  854. (when (file-directory-p dir)
  855. (dolist (file (file-name-all-completions "" dir))
  856. (when (string-match suffix file)
  857. (unless (string-match "pkg.elc?$" file)
  858. (setq short-name (substring file 0 (match-beginning 0)))
  859. (if (setq old-val (gethash short-name cands))
  860. (progn
  861. ;; assume going up directory once will resolve name clash
  862. (setq dir-parent (counsel-directory-name (cdr old-val)))
  863. (puthash short-name
  864. (cons
  865. (counsel-string-compose dir-parent (car old-val))
  866. (cdr old-val))
  867. cands)
  868. (setq dir-parent (counsel-directory-name dir))
  869. (puthash (concat dir-parent short-name)
  870. (cons
  871. (propertize
  872. (counsel-string-compose
  873. dir-parent short-name)
  874. 'full-name (expand-file-name file dir))
  875. dir)
  876. cands))
  877. (puthash short-name
  878. (cons (propertize
  879. short-name
  880. 'full-name (expand-file-name file dir))
  881. dir)
  882. cands)))))))
  883. (maphash (lambda (_k v) (push (car v) res)) cands)
  884. (nreverse res)))
  885. ;;;###autoload
  886. (defun counsel-load-library ()
  887. "Load a selected the Emacs Lisp library.
  888. The libraries are offered from `load-path'."
  889. (interactive)
  890. (let ((cands (counsel-library-candidates)))
  891. (ivy-read "Load library: " cands
  892. :action (lambda (x)
  893. (load-library
  894. (get-text-property 0 'full-name x)))
  895. :keymap counsel-describe-map)))
  896. (ivy-set-actions
  897. 'counsel-load-library
  898. '(("d" counsel--find-symbol "definition")))
  899. ;;** `counsel-find-library'
  900. (declare-function find-library-name "find-func")
  901. (defun counsel-find-library-other-window (library)
  902. (let ((buf (find-file-noselect (find-library-name library))))
  903. (pop-to-buffer buf 'other-window)))
  904. (defun counsel-find-library-other-frame (library)
  905. (let ((buf (find-file-noselect (find-library-name library))))
  906. (condition-case nil
  907. (switch-to-buffer-other-frame buf)
  908. (error (pop-to-buffer buf)))))
  909. (ivy-set-actions
  910. 'counsel-find-library
  911. '(("j" counsel-find-library-other-window "other window")
  912. ("f" counsel-find-library-other-frame "other frame")))
  913. ;;;###autoload
  914. (defun counsel-find-library ()
  915. "Visit a selected the Emacs Lisp library.
  916. The libraries are offered from `load-path'."
  917. (interactive)
  918. (let ((cands (counsel-library-candidates)))
  919. (ivy-read "Find library: " cands
  920. :action #'counsel--find-symbol
  921. :keymap counsel-describe-map
  922. :caller 'counsel-find-library)))
  923. ;;** `counsel-load-theme'
  924. (declare-function powerline-reset "ext:powerline")
  925. (defun counsel-load-theme-action (x)
  926. "Disable current themes and load theme X."
  927. (condition-case nil
  928. (progn
  929. (mapc #'disable-theme custom-enabled-themes)
  930. (load-theme (intern x) t)
  931. (when (fboundp 'powerline-reset)
  932. (powerline-reset)))
  933. (error "Problem loading theme %s" x)))
  934. ;;;###autoload
  935. (defun counsel-load-theme ()
  936. "Forward to `load-theme'.
  937. Usable with `ivy-resume', `ivy-next-line-and-call' and
  938. `ivy-previous-line-and-call'."
  939. (interactive)
  940. (ivy-read "Load custom theme: "
  941. (mapcar 'symbol-name
  942. (custom-available-themes))
  943. :action #'counsel-load-theme-action
  944. :caller 'counsel-load-theme))
  945. ;;** `counsel-descbinds'
  946. (ivy-set-actions
  947. 'counsel-descbinds
  948. '(("d" counsel-descbinds-action-find "definition")
  949. ("I" counsel-descbinds-action-info "info")
  950. ("x" counsel-descbinds-action-exec "execute")))
  951. (defvar counsel-descbinds-history nil
  952. "History for `counsel-descbinds'.")
  953. (defun counsel--descbinds-cands (&optional prefix buffer)
  954. "Get key bindings starting with PREFIX in BUFFER.
  955. See `describe-buffer-bindings' for further information."
  956. (let ((buffer (or buffer (current-buffer)))
  957. (re-exclude (regexp-opt
  958. '("<vertical-line>" "<bottom-divider>" "<right-divider>"
  959. "<mode-line>" "<C-down-mouse-2>" "<left-fringe>"
  960. "<right-fringe>" "<header-line>"
  961. "<vertical-scroll-bar>" "<horizontal-scroll-bar>")))
  962. res)
  963. (with-temp-buffer
  964. (let ((indent-tabs-mode t))
  965. (describe-buffer-bindings buffer prefix))
  966. (goto-char (point-min))
  967. ;; Skip the "Key translations" section
  968. (re-search-forward " ")
  969. (forward-char 1)
  970. (while (not (eobp))
  971. (when (looking-at "^\\([^\t\n]+\\)[\t ]*\\(.*\\)$")
  972. (let ((key (match-string 1))
  973. (fun (match-string 2))
  974. cmd)
  975. (unless (or (member fun '("??" "self-insert-command"))
  976. (string-match re-exclude key)
  977. (not (or (commandp (setq cmd (intern-soft fun)))
  978. (member fun '("Prefix Command")))))
  979. (push
  980. (cons (format
  981. "%-15s %s"
  982. (propertize key 'face 'counsel-key-binding)
  983. fun)
  984. (cons key cmd))
  985. res))))
  986. (forward-line 1)))
  987. (nreverse res)))
  988. (defcustom counsel-descbinds-function #'describe-function
  989. "Function to call to describe a function passed as parameter."
  990. :type 'function)
  991. (defun counsel-descbinds-action-describe (x)
  992. "Describe function of candidate X.
  993. See `describe-function' for further information."
  994. (let ((cmd (cddr x)))
  995. (funcall counsel-descbinds-function cmd)))
  996. (defun counsel-descbinds-action-exec (x)
  997. "Run candidate X.
  998. See `execute-extended-command' for further information."
  999. (let ((cmd (cddr x)))
  1000. (command-execute cmd 'record)))
  1001. (defun counsel-descbinds-action-find (x)
  1002. "Find symbol definition of candidate X.
  1003. See `counsel--find-symbol' for further information."
  1004. (let ((cmd (cddr x)))
  1005. (counsel--find-symbol (symbol-name cmd))))
  1006. (defun counsel-descbinds-action-info (x)
  1007. "Display symbol definition of candidate X, as found in the relevant manual.
  1008. See `info-lookup-symbol' for further information."
  1009. (let ((cmd (cddr x)))
  1010. (counsel-info-lookup-symbol (symbol-name cmd))))
  1011. ;;;###autoload
  1012. (defun counsel-descbinds (&optional prefix buffer)
  1013. "Show a list of all defined keys and their definitions.
  1014. If non-nil, show only bindings that start with PREFIX.
  1015. BUFFER defaults to the current one."
  1016. (interactive)
  1017. (ivy-read "Bindings: " (counsel--descbinds-cands prefix buffer)
  1018. :action #'counsel-descbinds-action-describe
  1019. :history 'counsel-descbinds-history
  1020. :caller 'counsel-descbinds))
  1021. ;;** `counsel-describe-face'
  1022. (defcustom counsel-describe-face-function #'describe-face
  1023. "Function to call to describe a face or face name argument."
  1024. :type 'function)
  1025. (defun counsel--face-at-point ()
  1026. "Return name of face around point.
  1027. Try detecting a face name in the text around point before falling
  1028. back to the face of the character after point, and finally the
  1029. `default' face."
  1030. (symbol-name (or (face-at-point t) 'default)))
  1031. ;;;###autoload
  1032. (defun counsel-describe-face ()
  1033. "Completion for `describe-face'."
  1034. (interactive)
  1035. (ivy-read "Face: " (face-list)
  1036. :require-match t
  1037. :history 'face-name-history
  1038. :preselect (counsel--face-at-point)
  1039. :action counsel-describe-face-function
  1040. :caller 'counsel-describe-face))
  1041. (ivy-configure 'counsel-describe-face
  1042. :sort-fn #'ivy-string<)
  1043. (defun counsel-customize-face (name)
  1044. "Customize face with NAME."
  1045. (customize-face (intern name)))
  1046. (defun counsel-customize-face-other-window (name)
  1047. "Customize face with NAME in another window."
  1048. (customize-face-other-window (intern name)))
  1049. (ivy-set-actions
  1050. 'counsel-describe-face
  1051. '(("c" counsel-customize-face "customize")
  1052. ("C" counsel-customize-face-other-window "customize other window")))
  1053. ;;** `counsel-faces'
  1054. (defvar counsel--faces-format "%-40s %s")
  1055. (defun counsel--faces-format-function (names)
  1056. "Format NAMES according to `counsel--faces-format'."
  1057. (let ((formatter
  1058. (lambda (name)
  1059. (format counsel--faces-format name
  1060. (propertize list-faces-sample-text
  1061. 'face (intern name))))))
  1062. (ivy--format-function-generic
  1063. (lambda (name)
  1064. (funcall formatter (ivy--add-face name 'ivy-current-match)))
  1065. formatter names "\n")))
  1066. ;;;###autoload
  1067. (defun counsel-faces ()
  1068. "Complete faces with preview.
  1069. Actions are provided by default for describing or customizing the
  1070. selected face."
  1071. (interactive)
  1072. (let* ((names (mapcar #'symbol-name (face-list)))
  1073. (counsel--faces-format
  1074. (format "%%-%ds %%s"
  1075. (apply #'max 0 (mapcar #'string-width names)))))
  1076. (ivy-read "Face: " names
  1077. :require-match t
  1078. :history 'face-name-history
  1079. :preselect (counsel--face-at-point)
  1080. :action counsel-describe-face-function
  1081. :caller 'counsel-faces)))
  1082. (ivy-configure 'counsel-faces
  1083. :sort-fn #'ivy-string<
  1084. :format-fn #'counsel--faces-format-function)
  1085. (ivy-set-actions
  1086. 'counsel-faces
  1087. '(("c" counsel-customize-face "customize")
  1088. ("C" counsel-customize-face-other-window "customize other window")))
  1089. ;;* Git
  1090. ;;** `counsel-git'
  1091. (defvar counsel-git-cmd "git ls-files --full-name --"
  1092. "Command for `counsel-git'.")
  1093. (ivy-set-actions
  1094. 'counsel-git
  1095. '(("j" find-file-other-window "other window")
  1096. ("x" counsel-find-file-extern "open externally")))
  1097. (defun counsel--dominating-file (file &optional dir)
  1098. "Look up directory hierarchy for FILE, starting in DIR.
  1099. Like `locate-dominating-file', but DIR defaults to
  1100. `default-directory' and the return value is expanded."
  1101. (and (setq dir (locate-dominating-file (or dir default-directory) file))
  1102. (expand-file-name dir)))
  1103. (defun counsel-locate-git-root ()
  1104. "Return the root of the Git repository containing the current buffer."
  1105. (or (counsel--git-root)
  1106. (error "Not in a Git repository")))
  1107. (defun counsel-git-cands ()
  1108. (let ((default-directory (counsel-locate-git-root)))
  1109. (split-string
  1110. (shell-command-to-string counsel-git-cmd)
  1111. "\n"
  1112. t)))
  1113. ;;;###autoload
  1114. (defun counsel-git (&optional initial-input)
  1115. "Find file in the current Git repository.
  1116. INITIAL-INPUT can be given as the initial minibuffer input."
  1117. (interactive)
  1118. (counsel-require-program counsel-git-cmd)
  1119. (let ((default-directory (counsel-locate-git-root)))
  1120. (ivy-read "Find file: " (counsel-git-cands)
  1121. :initial-input initial-input
  1122. :action #'counsel-git-action
  1123. :caller 'counsel-git)))
  1124. (ivy-configure 'counsel-git
  1125. :occur #'counsel-git-occur)
  1126. (defun counsel-git-action (x)
  1127. "Find file X in current Git repository."
  1128. (with-ivy-window
  1129. (let ((default-directory (ivy-state-directory ivy-last)))
  1130. (find-file x))))
  1131. (defun counsel-git-occur (&optional _cands)
  1132. "Occur function for `counsel-git' using `counsel-cmd-to-dired'."
  1133. (cd (ivy-state-directory ivy-last))
  1134. (counsel-cmd-to-dired
  1135. (counsel--expand-ls
  1136. (format "%s | %s | xargs ls"
  1137. counsel-git-cmd
  1138. (counsel--file-name-filter)))))
  1139. (defvar counsel-dired-listing-switches "-alh"
  1140. "Switches passed to `ls' for `counsel-cmd-to-dired'.")
  1141. (defun counsel-cmd-to-dired (full-cmd &optional filter)
  1142. "Adapted from `find-dired'."
  1143. (let ((inhibit-read-only t))
  1144. (erase-buffer)
  1145. (dired-mode default-directory counsel-dired-listing-switches)
  1146. (insert " " default-directory ":\n")
  1147. (let ((point (point)))
  1148. (insert " " full-cmd "\n")
  1149. (dired-insert-set-properties point (point)))
  1150. (setq-local dired-sort-inhibit t)
  1151. (setq-local revert-buffer-function
  1152. (lambda (_1 _2) (counsel-cmd-to-dired full-cmd)))
  1153. (setq-local dired-subdir-alist
  1154. (list (cons default-directory (point-min-marker))))
  1155. (let ((proc (start-process-shell-command
  1156. "counsel-cmd" (current-buffer) full-cmd)))
  1157. (set-process-filter proc filter)
  1158. (set-process-sentinel
  1159. proc
  1160. (lambda (process _msg)
  1161. (when (and (eq (process-status process) 'exit)
  1162. (zerop (process-exit-status process)))
  1163. (goto-char (point-min))
  1164. (forward-line 2)
  1165. (dired-move-to-filename)))))))
  1166. ;;** `counsel-git-grep'
  1167. (defvar counsel-git-grep-map
  1168. (let ((map (make-sparse-keymap)))
  1169. (define-key map (kbd "C-l") 'ivy-call-and-recenter)
  1170. (define-key map (kbd "M-q") 'counsel-git-grep-query-replace)
  1171. (define-key map (kbd "C-c C-m") 'counsel-git-grep-switch-cmd)
  1172. (define-key map (kbd "C-x C-d") 'counsel-cd)
  1173. map))
  1174. (defvar counsel-git-grep-cmd-default "git --no-pager grep --full-name -n --no-color -i -I -e \"%s\""
  1175. "Initial command for `counsel-git-grep'.")
  1176. (defvar counsel-git-grep-cmd nil
  1177. "Store the command for `counsel-git-grep'.")
  1178. (defvar counsel-git-grep-history nil
  1179. "History for `counsel-git-grep'.")
  1180. (defvar counsel-git-grep-cmd-history
  1181. (list counsel-git-grep-cmd-default)
  1182. "History for `counsel-git-grep' shell commands.")
  1183. (defcustom counsel-grep-post-action-hook nil
  1184. "Hook that runs after the point moves to the next candidate.
  1185. Typical value: '(recenter)."
  1186. :type 'hook)
  1187. (defcustom counsel-git-grep-cmd-function #'counsel-git-grep-cmd-function-default
  1188. "How a git-grep shell call is built from the input."
  1189. :type '(radio
  1190. (function-item counsel-git-grep-cmd-function-default)
  1191. (function-item counsel-git-grep-cmd-function-ignore-order)
  1192. (function :tag "Other")))
  1193. (defun counsel-git-grep-cmd-function-default (str)
  1194. (format counsel-git-grep-cmd
  1195. (setq ivy--old-re
  1196. (if (eq ivy--regex-function #'ivy--regex-fuzzy)
  1197. (replace-regexp-in-string
  1198. "\n" "" (ivy--regex-fuzzy str))
  1199. (ivy--regex str t)))))
  1200. (defun counsel-git-grep-cmd-function-ignore-order (str)
  1201. (setq ivy--old-re (ivy--regex str t))
  1202. (let ((parts (split-string str " " t)))
  1203. (concat
  1204. "git --no-pager grep --full-name -n --no-color -i -e "
  1205. (mapconcat #'shell-quote-argument parts " --and -e "))))
  1206. (defun counsel-git-grep-function (string)
  1207. "Grep in the current Git repository for STRING."
  1208. (or
  1209. (ivy-more-chars)
  1210. (progn
  1211. (counsel--async-command
  1212. (funcall counsel-git-grep-cmd-function string))
  1213. nil)))
  1214. (defun counsel-git-grep-action (x)
  1215. "Go to occurrence X in current Git repository."
  1216. (when (string-match "\\`\\(.*?\\):\\([0-9]+\\):\\(.*\\)\\'" x)
  1217. (let ((file-name (match-string-no-properties 1 x))
  1218. (line-number (match-string-no-properties 2 x)))
  1219. (find-file (expand-file-name
  1220. file-name
  1221. (ivy-state-directory ivy-last)))
  1222. (goto-char (point-min))
  1223. (forward-line (1- (string-to-number line-number)))
  1224. (when (re-search-forward (ivy--regex ivy-text t) (line-end-position) t)
  1225. (when swiper-goto-start-of-match
  1226. (goto-char (match-beginning 0))))
  1227. (swiper--ensure-visible)
  1228. (run-hooks 'counsel-grep-post-action-hook)
  1229. (unless (eq ivy-exit 'done)
  1230. (swiper--cleanup)
  1231. (swiper--add-overlays (ivy--regex ivy-text))))))
  1232. (defun counsel-git-grep-transformer (str)
  1233. "Higlight file and line number in STR."
  1234. (when (string-match "\\`\\([^:]+\\):\\([^:]+\\):" str)
  1235. (ivy-add-face-text-property (match-beginning 1) (match-end 1)
  1236. 'ivy-grep-info
  1237. str)
  1238. (ivy-add-face-text-property (match-beginning 2) (match-end 2)
  1239. 'ivy-grep-line-number
  1240. str))
  1241. str)
  1242. (defvar counsel-git-grep-projects-alist nil
  1243. "An alist of project directory to \"git-grep\" command.
  1244. Allows to automatically use a custom \"git-grep\" command for all
  1245. files in a project.")
  1246. (defun counsel--git-grep-cmd-and-proj (cmd)
  1247. (let ((dd (expand-file-name default-directory))
  1248. proj)
  1249. (cond
  1250. ((stringp cmd))
  1251. (current-prefix-arg
  1252. (if (setq proj
  1253. (cl-find-if
  1254. (lambda (x)
  1255. (string-match (car x) dd))
  1256. counsel-git-grep-projects-alist))
  1257. (setq cmd (cdr proj))
  1258. (setq cmd
  1259. (ivy-read "cmd: " counsel-git-grep-cmd-history
  1260. :history 'counsel-git-grep-cmd-history
  1261. :re-builder #'ivy--regex))
  1262. (setq counsel-git-grep-cmd-history
  1263. (delete-dups counsel-git-grep-cmd-history))))
  1264. (t
  1265. (setq cmd counsel-git-grep-cmd-default)))
  1266. (cons proj cmd)))
  1267. (defun counsel--call (command &optional result-fn)
  1268. "Synchronously call COMMAND and return its output as a string.
  1269. COMMAND comprises the program name followed by its arguments, as
  1270. in `make-process'. Signal `file-error' and emit a warning if
  1271. COMMAND fails. Obey file handlers based on `default-directory'.
  1272. On success, RESULT-FN is called in output buffer with no arguments."
  1273. (let ((stderr (make-temp-file "counsel-call-stderr-"))
  1274. status)
  1275. (unwind-protect
  1276. (with-temp-buffer
  1277. (setq status (apply #'process-file (car command) nil
  1278. (list t stderr) nil (cdr command)))
  1279. (if (eq status 0)
  1280. (if result-fn
  1281. (funcall result-fn)
  1282. ;; Return all output except trailing newline.
  1283. (buffer-substring (point-min)
  1284. (- (point)
  1285. (if (eq (bobp) (bolp))
  1286. 0
  1287. 1))))
  1288. ;; Convert process status into error list.
  1289. (setq status (list 'file-error
  1290. (mapconcat #'identity `(,@command "failed") " ")
  1291. status))
  1292. ;; Print stderr contents, if any, to *Warnings* buffer.
  1293. (let ((msg (condition-case err
  1294. (unless (zerop (cadr (insert-file-contents
  1295. stderr nil nil nil t)))
  1296. (buffer-string))
  1297. (error (error-message-string err)))))
  1298. (lwarn 'ivy :warning "%s" (apply #'concat
  1299. (error-message-string status)
  1300. (and msg (list "\n" msg)))))
  1301. ;; Signal `file-error' with process status.
  1302. (signal (car status) (cdr status))))
  1303. (delete-file stderr))))
  1304. (defun counsel--command (&rest command)
  1305. "Forward COMMAND to `counsel--call'."
  1306. (counsel--call command))
  1307. (defun counsel--grep-unwind ()
  1308. (counsel-delete-process)
  1309. (swiper--cleanup))
  1310. ;;;###autoload
  1311. (defun counsel-git-grep (&optional initial-input initial-directory cmd)
  1312. "Grep for a string in the current Git repository.
  1313. INITIAL-INPUT can be given as the initial minibuffer input.
  1314. INITIAL-DIRECTORY, if non-nil, is used as the root directory for search.
  1315. When CMD is a string, use it as a \"git grep\" command.
  1316. When CMD is non-nil, prompt for a specific \"git grep\" command."
  1317. (interactive)
  1318. (let ((proj-and-cmd (counsel--git-grep-cmd-and-proj cmd))
  1319. proj)
  1320. (setq proj (car proj-and-cmd))
  1321. (setq counsel-git-grep-cmd (cdr proj-and-cmd))
  1322. (counsel-require-program counsel-git-grep-cmd)
  1323. (let ((collection-function
  1324. (if proj
  1325. #'counsel-git-grep-proj-function
  1326. #'counsel-git-grep-function))
  1327. (default-directory (or initial-directory
  1328. (if proj
  1329. (car proj)
  1330. (counsel-locate-git-root)))))
  1331. (ivy-read "git grep: " collection-function
  1332. :initial-input initial-input
  1333. :dynamic-collection t
  1334. :keymap counsel-git-grep-map
  1335. :action #'counsel-git-grep-action
  1336. :history 'counsel-git-grep-history
  1337. :caller 'counsel-git-grep))))
  1338. (ivy-configure 'counsel-git-grep
  1339. :occur #'counsel-git-grep-occur
  1340. :unwind-fn #'counsel--grep-unwind
  1341. :index-fn #'ivy-recompute-index-swiper-async
  1342. :display-transformer-fn #'counsel-git-grep-transformer
  1343. :grep-p t
  1344. :exit-codes '(1 "No matches found"))
  1345. (defun counsel-git-grep-proj-function (str)
  1346. "Grep for STR in the current Git repository."
  1347. (or
  1348. (ivy-more-chars)
  1349. (let ((regex (setq ivy--old-re
  1350. (ivy--regex str t))))
  1351. (counsel--async-command (format counsel-git-grep-cmd regex))
  1352. nil)))
  1353. (defun counsel-git-grep-switch-cmd ()
  1354. "Set `counsel-git-grep-cmd' to a different value."
  1355. (interactive)
  1356. (setq counsel-git-grep-cmd
  1357. (ivy-read "cmd: " counsel-git-grep-cmd-history
  1358. :history 'counsel-git-grep-cmd-history))
  1359. (setq counsel-git-grep-cmd-history
  1360. (delete-dups counsel-git-grep-cmd-history))
  1361. (unless (ivy-state-dynamic-collection ivy-last)
  1362. (setq ivy--all-candidates
  1363. (all-completions "" 'counsel-git-grep-function))))
  1364. (defun counsel--normalize-grep-match (str)
  1365. ;; Prepend ./ if necessary:
  1366. (unless (ivy--starts-with-dotslash str)
  1367. (setq str (concat "./" str)))
  1368. ;; Remove column info if any:
  1369. (save-match-data
  1370. (when (string-match
  1371. "[^\n:]+?[^\n/:]:[\t ]*[1-9][0-9]*[\t ]*:\\([1-9][0-9]*:\\)"
  1372. str)
  1373. (setq str (replace-match "" t t str 1))))
  1374. str)
  1375. (defun counsel--git-grep-occur-cmd (input)
  1376. (let* ((regex (funcall ivy--regex-function input))
  1377. (regex (if (eq ivy--regex-function #'ivy--regex-fuzzy)
  1378. (replace-regexp-in-string "\n" "" regex)
  1379. regex))
  1380. (positive-pattern (replace-regexp-in-string
  1381. ;; git-grep can't handle .*?
  1382. "\\.\\*\\?" ".*"
  1383. (ivy-re-to-str regex)))
  1384. (negative-patterns
  1385. (if (stringp regex) ""
  1386. (mapconcat (lambda (x)
  1387. (and (null (cdr x))
  1388. (format "| grep -v %s" (car x))))
  1389. regex
  1390. " "))))
  1391. (concat (format counsel-git-grep-cmd positive-pattern) negative-patterns)))
  1392. (defun counsel-git-grep-occur (&optional _cands)
  1393. "Generate a custom occur buffer for `counsel-git-grep'."
  1394. (counsel-grep-like-occur #'counsel--git-grep-occur-cmd))
  1395. (defun counsel-git-grep-query-replace ()
  1396. "Start `query-replace' with string to replace from last search string."
  1397. (interactive)
  1398. (unless (window-minibuffer-p)
  1399. (user-error
  1400. "Should only be called in the minibuffer through `counsel-git-grep-map'"))
  1401. (let* ((enable-recursive-minibuffers t)
  1402. (from (ivy--regex ivy-text))
  1403. (to (query-replace-read-to from "Query replace" t)))
  1404. (ivy-exit-with-action
  1405. (lambda (_)
  1406. (let (done-buffers)
  1407. (dolist (cand ivy--old-cands)
  1408. (when (string-match "\\`\\(.*?\\):\\([0-9]+\\):\\(.*\\)\\'" cand)
  1409. (with-ivy-window
  1410. (let ((file-name (match-string-no-properties 1 cand)))
  1411. (setq file-name (expand-file-name
  1412. file-name
  1413. (ivy-state-directory ivy-last)))
  1414. (unless (member file-name done-buffers)
  1415. (push file-name done-buffers)
  1416. (find-file file-name)
  1417. (goto-char (point-min)))
  1418. (perform-replace from to t t nil))))))))))
  1419. ;;** `counsel-git-stash'
  1420. (defun counsel-git-stash-kill-action (x)
  1421. "Add git stash command to kill ring.
  1422. The git command applies the stash entry where candidate X was found in."
  1423. (when (string-match "\\([^:]+\\):" x)
  1424. (kill-new (message (format "git stash apply %s" (match-string 1 x))))))
  1425. ;;;###autoload
  1426. (defun counsel-git-stash ()
  1427. "Search through all available git stashes."
  1428. (interactive)
  1429. (let* ((default-directory (counsel-locate-git-root))
  1430. (cands (split-string (shell-command-to-string
  1431. "IFS=$'\n'
  1432. for i in `git stash list --format=\"%gd\"`; do
  1433. git stash show -p $i | grep -H --label=\"$i\" \"$1\"
  1434. done") "\n" t)))
  1435. (ivy-read "git stash: " cands
  1436. :action #'counsel-git-stash-kill-action
  1437. :caller 'counsel-git-stash)))
  1438. ;;** `counsel-git-log'
  1439. (defvar counsel-git-log-cmd "GIT_PAGER=cat git log --grep '%s'"
  1440. "Command used for \"git log\".")
  1441. (defun counsel-git-log-function (str)
  1442. "Search for STR in git log."
  1443. (or
  1444. (ivy-more-chars)
  1445. (progn
  1446. ;; `counsel--yank-pop-format-function' uses this
  1447. (setq ivy--old-re (funcall ivy--regex-function str))
  1448. (counsel--async-command
  1449. ;; "git log --grep" likes to have groups quoted e.g. \(foo\).
  1450. ;; But it doesn't like the non-greedy ".*?".
  1451. (format counsel-git-log-cmd
  1452. (replace-regexp-in-string "\\.\\*\\?" ".*"
  1453. (ivy-re-to-str ivy--old-re))))
  1454. nil)))
  1455. (defun counsel-git-log-action (x)
  1456. "Add candidate X to kill ring."
  1457. (message "%S" (kill-new x)))
  1458. (declare-function magit-show-commit "ext:magit-diff")
  1459. (defun counsel-git-log-show-commit-action (log-entry)
  1460. "Visit the commit corresponding to LOG-ENTRY."
  1461. (require 'magit-diff)
  1462. (let ((commit (substring-no-properties log-entry 0 (string-match-p "\\W" log-entry))))
  1463. (magit-show-commit commit)))
  1464. (ivy-set-actions
  1465. 'counsel-git-log
  1466. '(("v" counsel-git-log-show-commit-action "visit commit")))
  1467. ;;** `counsel-git-change-worktree'
  1468. (defun counsel-git-change-worktree-action (git-root-dir tree)
  1469. "Find the corresponding file in the worktree located at tree.
  1470. The current buffer is assumed to be in a subdirectory of GIT-ROOT-DIR.
  1471. TREE is the selected candidate."
  1472. (let* ((new-root-dir (counsel-git-worktree-parse-root tree))
  1473. (tree-filename (file-relative-name buffer-file-name git-root-dir))
  1474. (file-name (expand-file-name tree-filename new-root-dir)))
  1475. (find-file file-name)))
  1476. (defun counsel-git-worktree-list ()
  1477. "List worktrees in the Git repository containing the current buffer."
  1478. (let ((default-directory (counsel-locate-git-root)))
  1479. (split-string (shell-command-to-string "git worktree list") "\n" t)))
  1480. (defun counsel-git-worktree-parse-root (tree)
  1481. "Return worktree from candidate TREE."
  1482. (substring tree 0 (string-match-p " " tree)))
  1483. (defun counsel-git-close-worktree-files-action (root-dir)
  1484. "Close all buffers from the worktree located at ROOT-DIR."
  1485. (setq root-dir (counsel-git-worktree-parse-root root-dir))
  1486. (save-excursion
  1487. (dolist (buf (buffer-list))
  1488. (set-buffer buf)
  1489. (and buffer-file-name
  1490. (string= "." (file-relative-name root-dir (counsel-locate-git-root)))
  1491. (kill-buffer buf)))))
  1492. (ivy-set-actions
  1493. 'counsel-git-change-worktree
  1494. '(("k" counsel-git-close-worktree-files-action "kill all")))
  1495. ;;;###autoload
  1496. (defun counsel-git-change-worktree ()
  1497. "Find the file corresponding to the current buffer on a different worktree."
  1498. (interactive)
  1499. (let ((default-directory (counsel-locate-git-root)))
  1500. (ivy-read "Select worktree: "
  1501. (or (cl-delete default-directory (counsel-git-worktree-list)
  1502. :key #'counsel-git-worktree-parse-root :test #'string=)
  1503. (error "No other worktrees!"))
  1504. :action (lambda (tree)
  1505. (counsel-git-change-worktree-action
  1506. (ivy-state-directory ivy-last) tree))
  1507. :require-match t
  1508. :caller 'counsel-git-change-worktree)))
  1509. ;;** `counsel-git-checkout'
  1510. (defun counsel-git-checkout-action (branch)
  1511. "Switch branch by invoking git-checkout(1).
  1512. The command is passed a single argument comprising all characters
  1513. in BRANCH up to, but not including, the first space
  1514. character (#x20), or the string's end if it lacks a space."
  1515. (shell-command
  1516. (format "git checkout %s"
  1517. (shell-quote-argument
  1518. (substring branch 0 (string-match-p " " branch))))))
  1519. (defun counsel-git-branch-list ()
  1520. "Return list of branches in the current Git repository.
  1521. Value comprises all local and remote branches bar the one
  1522. currently checked out."
  1523. (cl-mapcan (lambda (line)
  1524. (and (string-match "\\`[[:blank:]]+" line)
  1525. (list (substring line (match-end 0)))))
  1526. (let ((default-directory (counsel-locate-git-root)))
  1527. (split-string (shell-command-to-string "git branch -vv --all")
  1528. "\n" t))))
  1529. ;;;###autoload
  1530. (defun counsel-git-checkout ()
  1531. "Call the \"git checkout\" command."
  1532. (interactive)
  1533. (ivy-read "Checkout branch: " (counsel-git-branch-list)
  1534. :action #'counsel-git-checkout-action
  1535. :caller 'counsel-git-checkout))
  1536. (defvar counsel-yank-pop-truncate-radius)
  1537. (defun counsel--git-log-format-function (str)
  1538. (let ((counsel-yank-pop-truncate-radius 5))
  1539. (counsel--yank-pop-format-function str)))
  1540. ;;;###autoload
  1541. (defun counsel-git-log ()
  1542. "Call the \"git log --grep\" shell command."
  1543. (interactive)
  1544. (ivy-read "Grep log: " #'counsel-git-log-function
  1545. :dynamic-collection t
  1546. :action #'counsel-git-log-action
  1547. :caller 'counsel-git-log))
  1548. (ivy-configure 'counsel-git-log
  1549. :height 4
  1550. :unwind-fn #'counsel-delete-process
  1551. :format-fn #'counsel--git-log-format-function)
  1552. (add-to-list 'counsel-async-split-string-re-alist '(counsel-git-log . "^commit "))
  1553. (add-to-list 'counsel-async-ignore-re-alist '(counsel-git-log . "^[ \n]*$"))
  1554. ;;* File
  1555. ;;** `counsel-find-file'
  1556. (defvar counsel-find-file-map
  1557. (let ((map (make-sparse-keymap)))
  1558. (define-key map (kbd "C-DEL") 'counsel-up-directory)
  1559. (define-key map (kbd "C-<backspace>") 'counsel-up-directory)
  1560. (define-key map (kbd "`") (ivy-make-magic-action 'counsel-find-file "b"))
  1561. map))
  1562. (when (executable-find "git")
  1563. (add-to-list 'ivy-ffap-url-functions 'counsel-github-url-p)
  1564. (add-to-list 'ivy-ffap-url-functions 'counsel-emacs-url-p))
  1565. (add-to-list 'ivy-ffap-url-functions 'counsel-url-expand)
  1566. (defun counsel-find-file-cd-bookmark-action (_)
  1567. "Reset `counsel-find-file' from selected directory."
  1568. (ivy-read "cd: "
  1569. (progn
  1570. (ivy--virtual-buffers)
  1571. (delete-dups
  1572. (mapcar (lambda (x) (file-name-directory (cdr x)))
  1573. ivy--virtual-buffers)))
  1574. :action (lambda (x)
  1575. (let ((default-directory (file-name-directory x)))
  1576. (counsel-find-file)))))
  1577. (defcustom counsel-root-command "sudo"
  1578. "Command to gain root privileges."
  1579. :type 'string)
  1580. (defun counsel-find-file-as-root (x)
  1581. "Find file X with root privileges."
  1582. (counsel-require-program counsel-root-command)
  1583. (let* ((host (file-remote-p x 'host))
  1584. (file-name (format "/%s:%s:%s"
  1585. counsel-root-command
  1586. (or host "")
  1587. (expand-file-name
  1588. (if host
  1589. (file-remote-p x 'localname)
  1590. x)))))
  1591. ;; If the current buffer visits the same file we are about to open,
  1592. ;; replace the current buffer with the new one.
  1593. (if (eq (current-buffer) (get-file-buffer x))
  1594. (find-alternate-file file-name)
  1595. (find-file file-name))))
  1596. (defun counsel--yes-or-no-p (fmt &rest args)
  1597. "Ask user a yes or no question created using FMT and ARGS.
  1598. If Emacs 26 user option `read-answer-short' is bound, use it to
  1599. choose between `yes-or-no-p' and `y-or-n-p'; otherwise default to
  1600. `yes-or-no-p'."
  1601. (funcall (if (and (boundp 'read-answer-short)
  1602. (cond ((eq read-answer-short t))
  1603. ((eq read-answer-short 'auto)
  1604. (eq (symbol-function 'yes-or-no-p) 'y-or-n-p))))
  1605. #'y-or-n-p
  1606. #'yes-or-no-p)
  1607. (apply #'format fmt args)))
  1608. (defun counsel-find-file-copy (x)
  1609. "Copy file X."
  1610. (require 'dired-aux)
  1611. (counsel--find-file-1 "Copy file to: "
  1612. ivy--directory
  1613. (lambda (new-name)
  1614. (dired-copy-file x new-name 1))
  1615. 'counsel-find-file-copy))
  1616. (defun counsel-find-file-delete (x)
  1617. "Delete file X."
  1618. (when (or delete-by-moving-to-trash
  1619. ;; `dired-delete-file', which see, already prompts for directories
  1620. (eq t (car (file-attributes x)))
  1621. (counsel--yes-or-no-p "Delete %s? " x))
  1622. (dired-delete-file x dired-recursive-deletes delete-by-moving-to-trash)
  1623. (dired-clean-up-after-deletion x)
  1624. (let ((win (and (not (eq ivy-exit 'done))
  1625. (active-minibuffer-window))))
  1626. (when win (with-selected-window win (ivy--cd ivy--directory))))))
  1627. (defun counsel-find-file-move (x)
  1628. "Move or rename file X."
  1629. (require 'dired-aux)
  1630. (counsel--find-file-1 "Rename file to: "
  1631. ivy--directory
  1632. (lambda (new-name)
  1633. (dired-rename-file x new-name 1))
  1634. 'counsel-find-file-move))
  1635. (defun counsel-find-file-mkdir-action (_x)
  1636. "Create a directory and any nonexistent parent dirs from `ivy-text'."
  1637. (let ((dir (file-name-as-directory
  1638. (expand-file-name ivy-text ivy--directory)))
  1639. (win (and (not (eq ivy-exit 'done))
  1640. (active-minibuffer-window))))
  1641. (make-directory dir t)
  1642. (when win (with-selected-window win (ivy--cd dir)))))
  1643. (ivy-set-actions
  1644. 'counsel-find-file
  1645. '(("j" find-file-other-window "other window")
  1646. ("f" find-file-other-frame "other frame")
  1647. ("b" counsel-find-file-cd-bookmark-action "cd bookmark")
  1648. ("x" counsel-find-file-extern "open externally")
  1649. ("r" counsel-find-file-as-root "open as root")
  1650. ("R" find-file-read-only "read only")
  1651. ("k" counsel-find-file-delete "delete")
  1652. ("c" counsel-find-file-copy "copy file")
  1653. ("m" counsel-find-file-move "move or rename")
  1654. ("d" counsel-find-file-mkdir-action "mkdir")))
  1655. (defcustom counsel-find-file-at-point nil
  1656. "When non-nil, add file-at-point to the list of candidates."
  1657. :type 'boolean)
  1658. (defcustom counsel-preselect-current-file nil
  1659. "When non-nil, preselect current file in list of candidates."
  1660. :type 'boolean)
  1661. (defcustom counsel-find-file-ignore-regexp nil
  1662. "A regexp of files to ignore while in `counsel-find-file'.
  1663. These files are un-ignored if `ivy-text' matches them. The
  1664. common way to show all files is to start `ivy-text' with a dot.
  1665. Example value: \"\\(?:\\`[#.]\\)\\|\\(?:[#~]\\'\\)\". This will hide
  1666. temporary and lock files.
  1667. \\<ivy-minibuffer-map>
  1668. Choosing the dotfiles option, \"\\`\\.\", might be convenient,
  1669. since you can still access the dotfiles if your input starts with
  1670. a dot. The generic way to toggle ignored files is \\[ivy-toggle-ignore],
  1671. but the leading dot is a lot faster."
  1672. :type `(choice
  1673. (const :tag "None" nil)
  1674. (const :tag "Dotfiles and Lockfiles" "\\(?:\\`\\|[/\\]\\)\\(?:[#.]\\)")
  1675. (const :tag "Ignored Extensions"
  1676. ,(regexp-opt completion-ignored-extensions))
  1677. (regexp :tag "Regex")))
  1678. (defvar counsel--find-file-predicate nil
  1679. "When non-nil, `counsel--find-file-matcher' will use this predicate.")
  1680. (defun counsel--find-file-matcher (regexp candidates)
  1681. "Return REGEXP matching CANDIDATES.
  1682. Skip some dotfiles unless `ivy-text' requires them."
  1683. (let ((res
  1684. (ivy--re-filter
  1685. regexp candidates
  1686. (lambda (re-str)
  1687. (lambda (x)
  1688. (string-match re-str (directory-file-name x)))))))
  1689. (when counsel--find-file-predicate
  1690. (let ((default-directory ivy--directory))
  1691. (setq res (cl-remove-if-not counsel--find-file-predicate res))))
  1692. (if (or (null ivy-use-ignore)
  1693. (null counsel-find-file-ignore-regexp)
  1694. (string-match-p "\\`\\." ivy-text))
  1695. res
  1696. (or (cl-remove-if
  1697. (lambda (x)
  1698. (and
  1699. (string-match-p counsel-find-file-ignore-regexp x)
  1700. (not (member x ivy-extra-directories))))
  1701. res)
  1702. res))))
  1703. (declare-function ffap-guesser "ffap")
  1704. (defvar counsel-find-file-speedup-remote t
  1705. "Speed up opening remote files by disabling `find-file-hook' for them.")
  1706. (defcustom counsel-find-file-extern-extensions '("mp4" "mkv" "xlsx")
  1707. "List of extensions that make `counsel-find-file' use `counsel-find-file-extern'."
  1708. :type '(repeat string))
  1709. (defun counsel-find-file-action (x)
  1710. "Find file X."
  1711. (with-ivy-window
  1712. (cond ((and counsel-find-file-speedup-remote
  1713. (file-remote-p ivy--directory))
  1714. (let ((find-file-hook nil))
  1715. (find-file (expand-file-name x ivy--directory))))
  1716. ((member (file-name-extension x) counsel-find-file-extern-extensions)
  1717. (counsel-find-file-extern x))
  1718. (t
  1719. (find-file (expand-file-name x ivy--directory))))))
  1720. (defun counsel--preselect-file ()
  1721. "Return candidate to preselect during filename completion.
  1722. The preselect behavior can be customized via user options
  1723. `counsel-find-file-at-point' and
  1724. `counsel-preselect-current-file', which see."
  1725. (or
  1726. (when counsel-find-file-at-point
  1727. (require 'ffap)
  1728. (let ((f (ffap-guesser)))
  1729. (when f (expand-file-name f))))
  1730. (and counsel-preselect-current-file
  1731. buffer-file-name
  1732. (file-name-nondirectory buffer-file-name))))
  1733. (defun counsel--find-file-1 (prompt initial-input action caller)
  1734. (let ((default-directory
  1735. (if (eq major-mode 'dired-mode)
  1736. (dired-current-directory)
  1737. default-directory)))
  1738. (ivy-read prompt #'read-file-name-internal
  1739. :matcher #'counsel--find-file-matcher
  1740. :initial-input initial-input
  1741. :action action
  1742. :preselect (counsel--preselect-file)
  1743. :require-match 'confirm-after-completion
  1744. :history 'file-name-history
  1745. :keymap counsel-find-file-map
  1746. :caller caller)))
  1747. ;;;###autoload
  1748. (defun counsel-find-file (&optional initial-input)
  1749. "Forward to `find-file'.
  1750. When INITIAL-INPUT is non-nil, use it in the minibuffer during completion."
  1751. (interactive)
  1752. (counsel--find-file-1
  1753. "Find file: " initial-input
  1754. #'counsel-find-file-action
  1755. 'counsel-find-file))
  1756. (ivy-configure 'counsel-find-file
  1757. :occur #'counsel-find-file-occur
  1758. :display-transformer-fn #'ivy-read-file-transformer)
  1759. (defvar counsel-find-file-occur-cmd "ls -a | %s | xargs -d '\\n' ls -d --group-directories-first"
  1760. "Format string for `counsel-find-file-occur'.")
  1761. (defvar counsel-find-file-occur-use-find (not (eq system-type 'gnu/linux))
  1762. "When non-nil, `counsel-find-file-occur' will use \"find\" as the base cmd.")
  1763. (defun counsel--expand-ls (cmd)
  1764. "Expand CMD that ends in \"ls\" with switches."
  1765. (concat cmd " " counsel-dired-listing-switches " | sed -e \"s/^/ /\""))
  1766. (defvar counsel-file-name-filter-alist
  1767. '(("ag -i '%s'" . t)
  1768. ("ack -i '%s'" . t)
  1769. ("perl -ne '/(%s.*)/i && print \"$1\\n\";'" . t)
  1770. ("grep -i -E '%s'"))
  1771. "Alist of file name filtering commands.
  1772. The car is a shell command and the cdr is t when the shell
  1773. command supports look-arounds. The executable for the commands
  1774. will be checked for existence via `executable-find'. The first
  1775. one that exists will be used.")
  1776. (defun counsel--file-name-filter (&optional use-ignore)
  1777. "Return a command that filters a file list to match ivy candidates.
  1778. If USE-IGNORE is non-nil, try to generate a command that respects
  1779. `counsel-find-file-ignore-regexp'."
  1780. (let ((regex ivy--old-re))
  1781. (if (= 0 (length regex))
  1782. "cat"
  1783. (let ((filter-cmd (cl-find-if
  1784. (lambda (x)
  1785. (executable-find
  1786. (car (split-string (car x)))))
  1787. counsel-file-name-filter-alist))
  1788. cmd)
  1789. (when (and use-ignore ivy-use-ignore
  1790. counsel-find-file-ignore-regexp
  1791. (cdr filter-cmd)
  1792. (not (string-match-p "\\`\\." ivy-text))
  1793. (not (string-match-p counsel-find-file-ignore-regexp
  1794. (or (car ivy--old-cands) ""))))
  1795. (let ((ignore-re (list (counsel--elisp-to-pcre
  1796. counsel-find-file-ignore-regexp))))
  1797. (setq regex (if (stringp regex)
  1798. (list ignore-re (cons regex t))
  1799. (cons ignore-re regex)))))
  1800. (setq cmd (format (car filter-cmd)
  1801. (counsel--elisp-to-pcre regex (cdr filter-cmd))))
  1802. (if (string-match-p "csh\\'" shell-file-name)
  1803. (replace-regexp-in-string "\\?!" "?\\\\!" cmd)
  1804. cmd)))))
  1805. (defun counsel--occur-cmd-find ()
  1806. (let ((cmd (format
  1807. "find . -maxdepth 1 | %s | xargs -I {} find {} -maxdepth 0 -ls"
  1808. (counsel--file-name-filter t))))
  1809. (concat
  1810. (counsel--cmd-to-dired-by-type "d" cmd)
  1811. " && "
  1812. (counsel--cmd-to-dired-by-type "f" cmd))))
  1813. (defun counsel--cmd-to-dired-by-type (type cmd)
  1814. (let ((exclude-dots
  1815. (if (string-match "^\\." ivy-text)
  1816. ""
  1817. " | grep -v '/\\\\.'")))
  1818. (replace-regexp-in-string
  1819. " | grep"
  1820. (concat " -type " type exclude-dots " | grep") cmd)))
  1821. (defun counsel-find-file-occur (&optional _cands)
  1822. (require 'find-dired)
  1823. (cd ivy--directory)
  1824. (if counsel-find-file-occur-use-find
  1825. (counsel-cmd-to-dired
  1826. (counsel--occur-cmd-find)
  1827. 'find-dired-filter)
  1828. (counsel-cmd-to-dired
  1829. (counsel--expand-ls
  1830. (format counsel-find-file-occur-cmd
  1831. (if (string-match-p "grep" counsel-find-file-occur-cmd)
  1832. ;; for backwards compatibility
  1833. (counsel--elisp-to-pcre ivy--old-re)
  1834. (counsel--file-name-filter t)))))))
  1835. (defvar counsel-up-directory-level t
  1836. "Control whether `counsel-up-directory' goes up a level or always a directory.
  1837. If non-nil, then `counsel-up-directory' will remove the final level of the path.
  1838. For example: /a/long/path/file.jpg => /a/long/path/
  1839. /a/long/path/ => /a/long/
  1840. If nil, then `counsel-up-directory' will go up a directory.
  1841. For example: /a/long/path/file.jpg => /a/long/
  1842. /a/long/path/ => /a/long/")
  1843. (defun counsel-up-directory ()
  1844. "Go to the parent directory preselecting the current one.
  1845. If the current directory is remote and it's not possible to go up any
  1846. further, make the remote prefix editable.
  1847. See variable `counsel-up-directory-level'."
  1848. (interactive)
  1849. (let* ((cur-dir (directory-file-name (expand-file-name ivy--directory)))
  1850. (up-dir (file-name-directory cur-dir)))
  1851. (if (and (file-remote-p cur-dir) (string-equal cur-dir up-dir))
  1852. (progn
  1853. ;; make the remote prefix editable
  1854. (setq ivy--old-cands nil)
  1855. (setq ivy--old-re nil)
  1856. (ivy-set-index 0)
  1857. (setq ivy--directory "")
  1858. (setq ivy--all-candidates nil)
  1859. (setq ivy-text "")
  1860. (delete-minibuffer-contents)
  1861. (insert up-dir))
  1862. (if (and counsel-up-directory-level (not (string= ivy-text "")))
  1863. (delete-region (line-beginning-position) (line-end-position))
  1864. (ivy--cd up-dir)
  1865. (setf (ivy-state-preselect ivy-last)
  1866. (file-name-as-directory (file-name-nondirectory cur-dir)))))))
  1867. (defun counsel-down-directory ()
  1868. "Descend into the current directory."
  1869. (interactive)
  1870. (ivy--directory-enter))
  1871. (defun counsel-at-git-issue-p ()
  1872. "When point is at an issue in a Git-versioned file, return the issue string."
  1873. (and (looking-at "#[0-9]+")
  1874. (or (eq (vc-backend buffer-file-name) 'Git)
  1875. (memq major-mode '(magit-commit-mode vc-git-log-view-mode))
  1876. (bound-and-true-p magit-commit-mode))
  1877. (match-string-no-properties 0)))
  1878. (defun counsel-github-url-p ()
  1879. "Return a Github issue URL at point."
  1880. (counsel-require-program "git")
  1881. (let ((url (counsel-at-git-issue-p)))
  1882. (when url
  1883. (let ((origin (shell-command-to-string
  1884. "git remote get-url origin"))
  1885. user repo)
  1886. (cond ((string-match "\\`git@github.com:\\([^/]+\\)/\\(.*\\)\\.git$"
  1887. origin)
  1888. (setq user (match-string 1 origin))
  1889. (setq repo (match-string 2 origin)))
  1890. ((string-match "\\`https://github.com/\\([^/]+\\)/\\(.*\\)$"
  1891. origin)
  1892. (setq user (match-string 1 origin))
  1893. (setq repo (match-string 2 origin))))
  1894. (when user
  1895. (setq url (format "https://github.com/%s/%s/issues/%s"
  1896. user repo (substring url 1))))))))
  1897. (defun counsel-emacs-url-p ()
  1898. "Return a Debbugs issue URL at point."
  1899. (counsel-require-program "git")
  1900. (let ((url (counsel-at-git-issue-p)))
  1901. (when url
  1902. (let ((origin (shell-command-to-string
  1903. "git remote get-url origin")))
  1904. (when (string-match "git.sv.gnu.org:/srv/git/emacs.git" origin)
  1905. (format "https://debbugs.gnu.org/cgi/bugreport.cgi?bug=%s"
  1906. (substring url 1)))))))
  1907. (defvar counsel-url-expansions-alist nil
  1908. "Map of regular expressions to expansions.
  1909. This variable should take the form of a list of (REGEXP . FORMAT)
  1910. pairs.
  1911. `counsel-url-expand' will expand the word at point according to
  1912. FORMAT for the first matching REGEXP. FORMAT can be either a
  1913. string or a function. If it is a string, it will be used as the
  1914. format string for the `format' function, with the word at point
  1915. as the next argument. If it is a function, it will be called
  1916. with the word at point as the sole argument.
  1917. For example, a pair of the form:
  1918. '(\"\\`BSERV-[[:digit:]]+\\'\" . \"https://jira.atlassian.com/browse/%s\")
  1919. will expand to URL `https://jira.atlassian.com/browse/BSERV-100'
  1920. when the word at point is BSERV-100.
  1921. If the format element is a function, more powerful
  1922. transformations are possible. As an example,
  1923. '(\"\\`issue\\([[:digit:]]+\\)\\'\" .
  1924. (lambda (word)
  1925. (concat \"https://debbugs.gnu.org/cgi/bugreport.cgi?bug=\"
  1926. (match-string 1 word))))
  1927. trims the \"issue\" prefix from the word at point before creating the URL.")
  1928. (defun counsel-url-expand ()
  1929. "Expand word at point using `counsel-url-expansions-alist'.
  1930. The first pair in the list whose regexp matches the word at point
  1931. will be expanded according to its format. This function is
  1932. intended to be used in `ivy-ffap-url-functions' to browse the
  1933. result as a URL."
  1934. (let ((word-at-point (current-word)))
  1935. (when word-at-point
  1936. (cl-some
  1937. (lambda (pair)
  1938. (let ((regexp (car pair))
  1939. (formatter (cdr pair)))
  1940. (when (string-match regexp word-at-point)
  1941. (if (functionp formatter)
  1942. (funcall formatter word-at-point)
  1943. (format formatter word-at-point)))))
  1944. counsel-url-expansions-alist))))
  1945. ;;** `counsel-dired'
  1946. (declare-function dired "dired")
  1947. ;;;###autoload
  1948. (defun counsel-dired (&optional initial-input)
  1949. "Forward to `dired'.
  1950. When INITIAL-INPUT is non-nil, use it in the minibuffer during completion."
  1951. (interactive)
  1952. (let ((counsel--find-file-predicate #'file-directory-p))
  1953. (counsel--find-file-1
  1954. "Dired (directory): " initial-input
  1955. (lambda (d) (dired (expand-file-name d)))
  1956. 'counsel-dired)))
  1957. (ivy-configure 'counsel-dired
  1958. :display-transformer-fn #'ivy-read-file-transformer)
  1959. ;;** `counsel-recentf'
  1960. (defvar recentf-list)
  1961. (declare-function recentf-mode "recentf")
  1962. ;;;###autoload
  1963. (defun counsel-recentf ()
  1964. "Find a file on `recentf-list'."
  1965. (interactive)
  1966. (require 'recentf)
  1967. (recentf-mode)
  1968. (ivy-read "Recentf: " (mapcar #'substring-no-properties recentf-list)
  1969. :action (lambda (f)
  1970. (with-ivy-window
  1971. (find-file f)))
  1972. :require-match t
  1973. :caller 'counsel-recentf))
  1974. (ivy-set-actions
  1975. 'counsel-recentf
  1976. '(("j" find-file-other-window "other window")
  1977. ("f" find-file-other-frame "other frame")
  1978. ("x" counsel-find-file-extern "open externally")))
  1979. (defun counsel-buffer-or-recentf-candidates ()
  1980. "Return candidates for `counsel-buffer-or-recentf'."
  1981. (require 'recentf)
  1982. (recentf-mode)
  1983. (let ((buffers
  1984. (delq nil
  1985. (mapcar (lambda (b)
  1986. (when (buffer-file-name b)
  1987. (buffer-file-name b)))
  1988. (buffer-list)))))
  1989. (append
  1990. buffers
  1991. (cl-remove-if (lambda (f) (member f buffers))
  1992. (mapcar #'substring-no-properties recentf-list)))))
  1993. ;;;###autoload
  1994. (defun counsel-buffer-or-recentf ()
  1995. "Find a buffer visiting a file or file on `recentf-list'."
  1996. (interactive)
  1997. (ivy-read "Buffer File or Recentf: " (counsel-buffer-or-recentf-candidates)
  1998. :action (lambda (s)
  1999. (with-ivy-window
  2000. (if (bufferp s)
  2001. (switch-to-buffer s)
  2002. (find-file s))))
  2003. :require-match t
  2004. :caller 'counsel-buffer-or-recentf))
  2005. (ivy-configure 'counsel-buffer-or-recentf
  2006. :display-transformer-fn #'counsel-buffer-or-recentf-transformer)
  2007. (ivy-set-actions
  2008. 'counsel-buffer-or-recentf
  2009. '(("j" find-file-other-window "other window")
  2010. ("f" find-file-other-frame "other frame")
  2011. ("x" counsel-find-file-extern "open externally")))
  2012. (defun counsel-buffer-or-recentf-transformer (var)
  2013. "Propertize VAR if it's a buffer visiting a file."
  2014. (if (member var (mapcar #'buffer-file-name (buffer-list)))
  2015. (ivy-append-face var 'ivy-highlight-face)
  2016. var))
  2017. ;;** `counsel-bookmark'
  2018. (defcustom counsel-bookmark-avoid-dired nil
  2019. "If non-nil, open directory bookmarks with `counsel-find-file'.
  2020. By default `counsel-bookmark' opens a dired buffer for directories."
  2021. :type 'boolean)
  2022. (defvar bookmark-alist)
  2023. (declare-function bookmark-location "bookmark")
  2024. (declare-function bookmark-all-names "bookmark")
  2025. (declare-function bookmark-get-filename "bookmark")
  2026. (declare-function bookmark-maybe-load-default-file "bookmark")
  2027. ;;;###autoload
  2028. (defun counsel-bookmark ()
  2029. "Forward to `bookmark-jump' or `bookmark-set' if bookmark doesn't exist."
  2030. (interactive)
  2031. (require 'bookmark)
  2032. (ivy-read "Create or jump to bookmark: "
  2033. (bookmark-all-names)
  2034. :history 'bookmark-history
  2035. :action (lambda (x)
  2036. (cond ((and counsel-bookmark-avoid-dired
  2037. (member x (bookmark-all-names))
  2038. (file-directory-p (bookmark-location x)))
  2039. (with-ivy-window
  2040. (let ((default-directory (bookmark-location x)))
  2041. (counsel-find-file))))
  2042. ((member x (bookmark-all-names))
  2043. (with-ivy-window
  2044. (bookmark-jump x)))
  2045. (t
  2046. (bookmark-set x))))
  2047. :caller 'counsel-bookmark))
  2048. (defun counsel--apply-bookmark-fn (fn)
  2049. "Return a function applying FN to a bookmark's location."
  2050. (lambda (bookmark)
  2051. (funcall fn (bookmark-location bookmark))))
  2052. (ivy-set-actions
  2053. 'counsel-bookmark
  2054. `(("d" bookmark-delete "delete")
  2055. ("e" bookmark-rename "edit")
  2056. ("x" ,(counsel--apply-bookmark-fn #'counsel-find-file-extern)
  2057. "open externally")
  2058. ("r" ,(counsel--apply-bookmark-fn #'counsel-find-file-as-root)
  2059. "open as root")))
  2060. ;;** `counsel-bookmarked-directory'
  2061. (defun counsel-bookmarked-directory--candidates ()
  2062. "Get a list of bookmarked directories sorted by file path."
  2063. (bookmark-maybe-load-default-file)
  2064. (sort (cl-remove-if-not
  2065. #'ivy--dirname-p
  2066. (delq nil (mapcar #'bookmark-get-filename bookmark-alist)))
  2067. #'string<))
  2068. ;;;###autoload
  2069. (defun counsel-bookmarked-directory ()
  2070. "Ivy interface for bookmarked directories.
  2071. With a prefix argument, this command creates a new bookmark which points to the
  2072. current value of `default-directory'."
  2073. (interactive)
  2074. (require 'bookmark)
  2075. (ivy-read "Bookmarked directory: "
  2076. (counsel-bookmarked-directory--candidates)
  2077. :caller 'counsel-bookmarked-directory
  2078. :action #'dired))
  2079. (ivy-set-actions 'counsel-bookmarked-directory
  2080. '(("j" dired-other-window "other window")
  2081. ("x" counsel-find-file-extern "open externally")
  2082. ("r" counsel-find-file-as-root "open as root")
  2083. ("f" (lambda (dir)
  2084. (let ((default-directory dir))
  2085. (call-interactively #'find-file)))
  2086. "find-file")))
  2087. ;;** `counsel-file-register'
  2088. ;;;###autoload
  2089. (defun counsel-file-register ()
  2090. "Search file in register.
  2091. You cannot use Emacs' normal register commands to create file
  2092. registers. Instead you must use the `set-register' function like
  2093. so: `(set-register ?i \"/home/eric/.emacs.d/init.el\")'. Now you
  2094. can use `C-x r j i' to open that file."
  2095. (interactive)
  2096. (ivy-read "File Register: "
  2097. ;; Use the `register-alist' variable to filter out file
  2098. ;; registers. Each entry for a file register will have the
  2099. ;; following layout:
  2100. ;;
  2101. ;; (NUMBER 'file . "string/path/to/file")
  2102. ;;
  2103. ;; So we go through each entry and see if the `cadr' is
  2104. ;; `eq' to the symbol `file'. If so then add the filename
  2105. ;; (`cddr') which `ivy-read' will use for its choices.
  2106. (mapcar (lambda (register-alist-entry)
  2107. (if (eq 'file (cadr register-alist-entry))
  2108. (cddr register-alist-entry)))
  2109. register-alist)
  2110. :require-match t
  2111. :history 'counsel-file-register
  2112. :caller 'counsel-file-register
  2113. :action (lambda (register-file)
  2114. (with-ivy-window (find-file register-file)))))
  2115. (ivy-configure 'counsel-file-register
  2116. :sort-fn #'ivy-string<)
  2117. (ivy-set-actions
  2118. 'counsel-file-register
  2119. '(("j" find-file-other-window "other window")))
  2120. ;;** `counsel-locate'
  2121. (defcustom counsel-locate-cmd (cond ((memq system-type '(darwin berkeley-unix))
  2122. 'counsel-locate-cmd-noregex)
  2123. ((and (eq system-type 'windows-nt)
  2124. (executable-find "es.exe"))
  2125. 'counsel-locate-cmd-es)
  2126. (t
  2127. 'counsel-locate-cmd-default))
  2128. "The function for producing a locate command string from the input.
  2129. The function takes a string - the current input, and returns a
  2130. string - the full shell command to run."
  2131. :type '(choice
  2132. (const :tag "Default" counsel-locate-cmd-default)
  2133. (const :tag "No regex" counsel-locate-cmd-noregex)
  2134. (const :tag "mdfind" counsel-locate-cmd-mdfind)
  2135. (const :tag "everything" counsel-locate-cmd-es)))
  2136. (ivy-set-actions
  2137. 'counsel-locate
  2138. '(("x" counsel-locate-action-extern "xdg-open")
  2139. ("r" counsel-find-file-as-root "open as root")
  2140. ("d" counsel-locate-action-dired "dired")))
  2141. (defvar counsel-locate-history nil
  2142. "History for `counsel-locate'.")
  2143. ;;;###autoload
  2144. (defun counsel-locate-action-extern (x)
  2145. "Pass X to `xdg-open' or equivalent command via the shell."
  2146. (interactive "FFile: ")
  2147. (if (and (eq system-type 'windows-nt)
  2148. (fboundp 'w32-shell-execute))
  2149. (w32-shell-execute "open" x)
  2150. (call-process-shell-command (format "%s %s"
  2151. (cl-case system-type
  2152. (darwin "open")
  2153. (cygwin "cygstart")
  2154. (t "xdg-open"))
  2155. (shell-quote-argument x))
  2156. nil 0)))
  2157. (defalias 'counsel-find-file-extern #'counsel-locate-action-extern)
  2158. (declare-function dired-jump "dired-x")
  2159. (defun counsel-locate-action-dired (x)
  2160. "Use `dired-jump' on X."
  2161. (dired-jump nil x))
  2162. (defun counsel-locate-cmd-default (input)
  2163. "Return a shell command based on INPUT."
  2164. (counsel-require-program "locate")
  2165. (format "locate -i --regex '%s'"
  2166. (counsel--elisp-to-pcre
  2167. (ivy--regex input))))
  2168. (defun counsel-locate-cmd-noregex (input)
  2169. "Return a shell command based on INPUT."
  2170. (counsel-require-program "locate")
  2171. (format "locate -i '%s'" input))
  2172. (defun counsel-locate-cmd-mdfind (input)
  2173. "Return a shell command based on INPUT."
  2174. (counsel-require-program "mdfind")
  2175. (format "mdfind -name '%s'" input))
  2176. (defvar w32-ansi-code-page)
  2177. (defun counsel-locate-cmd-es (input)
  2178. "Return a shell command based on INPUT."
  2179. (counsel-require-program "es.exe")
  2180. (let ((raw-string (format "es.exe -i -r -p %s"
  2181. (counsel--elisp-to-pcre
  2182. (ivy--regex input t)))))
  2183. ;; W32 don't use Unicode by default, so we encode search command
  2184. ;; to local codepage to support searching filename contains non-ASCII
  2185. ;; characters.
  2186. (if (and (eq system-type 'windows-nt)
  2187. (boundp 'w32-ansi-code-page))
  2188. (encode-coding-string raw-string
  2189. (intern (format "cp%d" w32-ansi-code-page)))
  2190. raw-string)))
  2191. (defun counsel-locate-function (input)
  2192. "Call the \"locate\" shell command with INPUT."
  2193. (or
  2194. (ivy-more-chars)
  2195. (progn
  2196. (counsel--async-command
  2197. (funcall counsel-locate-cmd input))
  2198. '("" "working..."))))
  2199. (defcustom counsel-locate-db-path "~/.local/mlocate.db"
  2200. "Location where to put the locatedb in case your home folder is encrypted."
  2201. :type 'file)
  2202. (defun counsel-file-stale-p (fname seconds)
  2203. "Return non-nil if FNAME was modified more than SECONDS ago."
  2204. (> (time-to-seconds
  2205. (time-subtract
  2206. (current-time)
  2207. (nth 5 (file-attributes fname))))
  2208. seconds))
  2209. (defun counsel--locate-updatedb ()
  2210. (when (file-exists-p "~/.Private")
  2211. (let ((db-fname (expand-file-name counsel-locate-db-path)))
  2212. (setenv "LOCATE_PATH" db-fname)
  2213. (when (or (not (file-exists-p db-fname))
  2214. (counsel-file-stale-p db-fname 60))
  2215. (message "Updating %s..." db-fname)
  2216. (counsel--command
  2217. "updatedb" "-l" "0" "-o" db-fname "-U" (expand-file-name "~"))))))
  2218. ;;;###autoload
  2219. (defun counsel-locate (&optional initial-input)
  2220. "Call the \"locate\" shell command.
  2221. INITIAL-INPUT can be given as the initial minibuffer input."
  2222. (interactive)
  2223. (counsel--locate-updatedb)
  2224. (ivy-read "Locate: " #'counsel-locate-function
  2225. :initial-input initial-input
  2226. :dynamic-collection t
  2227. :history 'counsel-locate-history
  2228. :action (lambda (file)
  2229. (when file
  2230. (with-ivy-window
  2231. (find-file
  2232. (concat (file-remote-p default-directory) file)))))
  2233. :caller 'counsel-locate))
  2234. (ivy-configure 'counsel-locate
  2235. :unwind-fn #'counsel-delete-process
  2236. :exit-codes '(1 "Nothing found"))
  2237. ;;** `counsel-fzf'
  2238. (defvar counsel-fzf-cmd "fzf -f \"%s\""
  2239. "Command for `counsel-fzf'.")
  2240. (defvar counsel--fzf-dir nil
  2241. "Store the base fzf directory.")
  2242. (defvar counsel-fzf-dir-function 'counsel-fzf-dir-function-projectile
  2243. "Function that returns a directory for fzf to use.")
  2244. (defun counsel-fzf-dir-function-projectile ()
  2245. (if (and
  2246. (fboundp 'projectile-project-p)
  2247. (fboundp 'projectile-project-root)
  2248. (projectile-project-p))
  2249. (projectile-project-root)
  2250. default-directory))
  2251. (defun counsel-fzf-function (str)
  2252. (let ((default-directory counsel--fzf-dir))
  2253. (setq ivy--old-re (ivy--regex-fuzzy str))
  2254. (counsel--async-command
  2255. (format counsel-fzf-cmd str)))
  2256. nil)
  2257. ;;;###autoload
  2258. (defun counsel-fzf (&optional initial-input initial-directory fzf-prompt)
  2259. "Open a file using the fzf shell command.
  2260. INITIAL-INPUT can be given as the initial minibuffer input.
  2261. INITIAL-DIRECTORY, if non-nil, is used as the root directory for search.
  2262. FZF-PROMPT, if non-nil, is passed as `ivy-read' prompt argument."
  2263. (interactive
  2264. (let ((fzf-basename (car (split-string counsel-fzf-cmd))))
  2265. (list nil
  2266. (when current-prefix-arg
  2267. (counsel-read-directory-name (concat
  2268. fzf-basename
  2269. " in directory: "))))))
  2270. (counsel-require-program counsel-fzf-cmd)
  2271. (setq counsel--fzf-dir
  2272. (or initial-directory
  2273. (funcall counsel-fzf-dir-function)))
  2274. (ivy-read (or fzf-prompt "fzf: ")
  2275. #'counsel-fzf-function
  2276. :initial-input initial-input
  2277. :re-builder #'ivy--regex-fuzzy
  2278. :dynamic-collection t
  2279. :action #'counsel-fzf-action
  2280. :caller 'counsel-fzf))
  2281. (ivy-configure 'counsel-fzf
  2282. :occur #'counsel-fzf-occur
  2283. :unwind-fn #'counsel-delete-process
  2284. :exit-codes '(1 "Nothing found"))
  2285. (defun counsel-fzf-action (x)
  2286. "Find file X in current fzf directory."
  2287. (with-ivy-window
  2288. (let ((default-directory counsel--fzf-dir))
  2289. (find-file x))))
  2290. (defun counsel-fzf-occur (&optional _cands)
  2291. "Occur function for `counsel-fzf' using `counsel-cmd-to-dired'."
  2292. (cd counsel--fzf-dir)
  2293. (counsel-cmd-to-dired
  2294. (counsel--expand-ls
  2295. (format
  2296. "%s --print0 | xargs -0 ls"
  2297. (format counsel-fzf-cmd ivy-text)))))
  2298. (ivy-set-actions
  2299. 'counsel-fzf
  2300. '(("x" counsel-locate-action-extern "xdg-open")
  2301. ("d" counsel-locate-action-dired "dired")))
  2302. ;;** `counsel-dpkg'
  2303. ;;;###autoload
  2304. (defun counsel-dpkg ()
  2305. "Call the \"dpkg\" shell command."
  2306. (interactive)
  2307. (counsel-require-program "dpkg")
  2308. (let ((cands (mapcar
  2309. (lambda (x)
  2310. (let ((y (split-string x " +")))
  2311. (cons (format "%-40s %s"
  2312. (ivy--truncate-string
  2313. (nth 1 y) 40)
  2314. (nth 4 y))
  2315. (mapconcat #'identity y " "))))
  2316. (split-string
  2317. (shell-command-to-string "dpkg -l | tail -n+6") "\n" t))))
  2318. (ivy-read "dpkg: " cands
  2319. :action (lambda (x)
  2320. (message (cdr x)))
  2321. :caller 'counsel-dpkg)))
  2322. ;;** `counsel-rpm'
  2323. ;;;###autoload
  2324. (defun counsel-rpm ()
  2325. "Call the \"rpm\" shell command."
  2326. (interactive)
  2327. (counsel-require-program "rpm")
  2328. (let ((cands (mapcar
  2329. (lambda (x)
  2330. (let ((y (split-string x "|")))
  2331. (cons (format "%-40s %s"
  2332. (ivy--truncate-string
  2333. (nth 0 y) 40)
  2334. (nth 1 y))
  2335. (mapconcat #'identity y " "))))
  2336. (split-string
  2337. (shell-command-to-string "rpm -qa --qf \"%{NAME}|%{SUMMARY}\\n\"") "\n" t))))
  2338. (ivy-read "rpm: " cands
  2339. :action (lambda (x)
  2340. (message (cdr x)))
  2341. :caller 'counsel-rpm)))
  2342. (defun counsel--find-return-list (args)
  2343. (unless (listp args)
  2344. (user-error "`counsel-file-jump-args' is a list now, please customize accordingly."))
  2345. (counsel--call
  2346. (cons find-program args)
  2347. (lambda ()
  2348. (let (files)
  2349. (goto-char (point-min))
  2350. (while (< (point) (point-max))
  2351. (when (looking-at "\\./")
  2352. (goto-char (match-end 0)))
  2353. (push (buffer-substring (point) (line-end-position)) files)
  2354. (beginning-of-line 2))
  2355. (nreverse files)))))
  2356. (defcustom counsel-file-jump-args (split-string ". -name .git -prune -o -type f -print")
  2357. "Arguments for the `find-command' when using `counsel-file-jump'."
  2358. :type '(repeat string))
  2359. ;;** `counsel-file-jump'
  2360. ;;;###autoload
  2361. (defun counsel-file-jump (&optional initial-input initial-directory)
  2362. "Jump to a file below the current directory.
  2363. List all files within the current directory or any of its sub-directories.
  2364. INITIAL-INPUT can be given as the initial minibuffer input.
  2365. INITIAL-DIRECTORY, if non-nil, is used as the root directory for search."
  2366. (interactive
  2367. (list nil
  2368. (when current-prefix-arg
  2369. (counsel-read-directory-name "From directory: "))))
  2370. (counsel-require-program find-program)
  2371. (let ((default-directory (or initial-directory default-directory)))
  2372. (ivy-read "Find file: "
  2373. (counsel--find-return-list counsel-file-jump-args)
  2374. :matcher #'counsel--find-file-matcher
  2375. :initial-input initial-input
  2376. :action #'find-file
  2377. :preselect (counsel--preselect-file)
  2378. :require-match 'confirm-after-completion
  2379. :history 'file-name-history
  2380. :keymap counsel-find-file-map
  2381. :caller 'counsel-file-jump)))
  2382. (ivy-set-actions
  2383. 'counsel-file-jump
  2384. `(("d" ,(lambda (x)
  2385. (dired (or (file-name-directory x) default-directory)))
  2386. "open in dired")))
  2387. (defcustom counsel-dired-jump-args (split-string ". -name .git -prune -o -type d -print")
  2388. "Arguments for the `find-command' when using `counsel-dired-jump'."
  2389. :type '(repeat string))
  2390. ;;** `counsel-dired-jump'
  2391. ;;;###autoload
  2392. (defun counsel-dired-jump (&optional initial-input initial-directory)
  2393. "Jump to a directory (see `dired-jump') below the current directory.
  2394. List all sub-directories within the current directory.
  2395. INITIAL-INPUT can be given as the initial minibuffer input.
  2396. INITIAL-DIRECTORY, if non-nil, is used as the root directory for search."
  2397. (interactive
  2398. (list nil
  2399. (when current-prefix-arg
  2400. (counsel-read-directory-name "From directory: "))))
  2401. (counsel-require-program find-program)
  2402. (let ((default-directory (or initial-directory default-directory)))
  2403. (ivy-read "Find directory: "
  2404. (cdr
  2405. (counsel--find-return-list counsel-dired-jump-args))
  2406. :matcher #'counsel--find-file-matcher
  2407. :initial-input initial-input
  2408. :action (lambda (d) (dired-jump nil (expand-file-name d)))
  2409. :history 'file-name-history
  2410. :keymap counsel-find-file-map
  2411. :caller 'counsel-dired-jump)))
  2412. ;;* Grep
  2413. (defun counsel--grep-mode-occur (git-grep-dir-is-file)
  2414. "Generate a custom occur buffer for grep like commands.
  2415. If GIT-GREP-DIR-IS-FILE is t, then `ivy-state-directory' is treated as a full
  2416. path to a file rather than a directory (e.g. for `counsel-grep-occur').
  2417. This function expects that the candidates have already been filtered.
  2418. It applies no filtering to ivy--all-candidates."
  2419. (unless (eq major-mode 'ivy-occur-grep-mode)
  2420. (ivy-occur-grep-mode))
  2421. (let ((directory
  2422. (if git-grep-dir-is-file
  2423. (file-name-directory (ivy-state-directory ivy-last))
  2424. (ivy-state-directory ivy-last))))
  2425. (setq default-directory directory)
  2426. ;; Need precise number of header lines for `wgrep' to work.
  2427. (insert (format "-*- mode:grep; default-directory: %S -*-\n\n\n" default-directory))
  2428. (insert (format "%d candidates:\n" (length ivy--all-candidates)))
  2429. (ivy--occur-insert-lines
  2430. (mapcar #'counsel--normalize-grep-match ivy--all-candidates))))
  2431. ;;** `counsel-ag'
  2432. (defvar counsel-ag-map
  2433. (let ((map (make-sparse-keymap)))
  2434. (define-key map (kbd "C-l") 'ivy-call-and-recenter)
  2435. (define-key map (kbd "M-q") 'counsel-git-grep-query-replace)
  2436. (define-key map (kbd "C-'") 'swiper-avy)
  2437. (define-key map (kbd "C-x C-d") 'counsel-cd)
  2438. map))
  2439. (defcustom counsel-ag-base-command
  2440. (if (memq system-type '(ms-dos windows-nt))
  2441. "ag --vimgrep %s"
  2442. "ag --nocolor --nogroup %s")
  2443. "Format string to use in `counsel-ag-function' to construct the command.
  2444. The %s will be replaced by optional extra ag arguments followed by the
  2445. regex string."
  2446. :type 'string)
  2447. (defvar counsel-ag-command nil)
  2448. (defvar counsel--grep-tool-look-around t)
  2449. (defvar counsel--regex-look-around nil)
  2450. (defconst counsel--command-args-separator "-- ")
  2451. (defun counsel--split-command-args (arguments)
  2452. "Split ARGUMENTS into its switches and search-term parts.
  2453. Return pair of corresponding strings (SWITCHES . SEARCH-TERM)."
  2454. (let ((switches "")
  2455. (search-term arguments))
  2456. (when (string-prefix-p "-" arguments)
  2457. (let ((index (string-match counsel--command-args-separator arguments)))
  2458. (when index
  2459. (setq search-term
  2460. (substring arguments (+ (length counsel--command-args-separator) index)))
  2461. (setq switches (substring arguments 0 index)))))
  2462. (cons switches search-term)))
  2463. (defun counsel--format-ag-command (extra-args needle)
  2464. "Construct a complete `counsel-ag-command' as a string.
  2465. EXTRA-ARGS is a string of the additional arguments.
  2466. NEEDLE is the search string."
  2467. (format counsel-ag-command
  2468. (if (string-match " \\(--\\) " extra-args)
  2469. (replace-match needle t t extra-args 1)
  2470. (concat extra-args " " needle))))
  2471. (defun counsel--grep-regex (str)
  2472. (counsel--elisp-to-pcre
  2473. (setq ivy--old-re
  2474. (funcall ivy--regex-function str))
  2475. counsel--regex-look-around))
  2476. (defun counsel--ag-extra-switches (regex)
  2477. "Get additional switches needed for look-arounds."
  2478. (and (stringp counsel--regex-look-around)
  2479. ;; using look-arounds
  2480. (string-match-p "\\`\\^(\\?[=!]" regex)
  2481. (concat " " counsel--regex-look-around " ")))
  2482. (defun counsel-ag-function (string)
  2483. "Grep in the current directory for STRING."
  2484. (let* ((command-args (counsel--split-command-args string))
  2485. (search-term (cdr command-args)))
  2486. (or
  2487. (let ((ivy-text search-term))
  2488. (ivy-more-chars))
  2489. (let* ((default-directory (ivy-state-directory ivy-last))
  2490. (regex (counsel--grep-regex search-term))
  2491. (switches (concat (car command-args)
  2492. (counsel--ag-extra-switches regex)
  2493. (and (ivy--case-fold-p string) " -i "))))
  2494. (counsel--async-command (counsel--format-ag-command
  2495. switches
  2496. (shell-quote-argument regex)))
  2497. nil))))
  2498. ;;;###autoload
  2499. (cl-defun counsel-ag (&optional initial-input initial-directory extra-ag-args ag-prompt
  2500. &key caller)
  2501. "Grep for a string in the current directory using ag.
  2502. INITIAL-INPUT can be given as the initial minibuffer input.
  2503. INITIAL-DIRECTORY, if non-nil, is used as the root directory for search.
  2504. EXTRA-AG-ARGS string, if non-nil, is appended to `counsel-ag-base-command'.
  2505. AG-PROMPT, if non-nil, is passed as `ivy-read' prompt argument.
  2506. CALLER is passed to `ivy-read'."
  2507. (interactive)
  2508. (setq counsel-ag-command counsel-ag-base-command)
  2509. (setq counsel--regex-look-around counsel--grep-tool-look-around)
  2510. (counsel-require-program counsel-ag-command)
  2511. (when current-prefix-arg
  2512. (setq initial-directory
  2513. (or initial-directory
  2514. (counsel-read-directory-name (concat
  2515. (car (split-string counsel-ag-command))
  2516. " in directory: "))))
  2517. (setq extra-ag-args
  2518. (or extra-ag-args
  2519. (read-from-minibuffer (format
  2520. "%s args: "
  2521. (car (split-string counsel-ag-command)))))))
  2522. (setq counsel-ag-command (counsel--format-ag-command (or extra-ag-args "") "%s"))
  2523. (let ((default-directory (or initial-directory
  2524. (counsel--git-root)
  2525. default-directory)))
  2526. (ivy-read (or ag-prompt
  2527. (concat (car (split-string counsel-ag-command)) ": "))
  2528. #'counsel-ag-function
  2529. :initial-input initial-input
  2530. :dynamic-collection t
  2531. :keymap counsel-ag-map
  2532. :history 'counsel-git-grep-history
  2533. :action #'counsel-git-grep-action
  2534. :caller (or caller 'counsel-ag))))
  2535. (ivy-configure 'counsel-ag
  2536. :occur #'counsel-ag-occur
  2537. :unwind-fn #'counsel--grep-unwind
  2538. :display-transformer-fn #'counsel-git-grep-transformer
  2539. :grep-p t
  2540. :exit-codes '(1 "No matches found"))
  2541. (defun counsel-read-directory-name (prompt)
  2542. "Read a directory name from user, a (partial) replacement of `read-directory-name'."
  2543. (let ((counsel--find-file-predicate #'file-directory-p))
  2544. (ivy-read prompt
  2545. #'read-file-name-internal
  2546. :matcher #'counsel--find-file-matcher
  2547. :history 'file-name-history
  2548. :keymap counsel-find-file-map
  2549. :caller 'counsel-read-directory-name)))
  2550. (ivy-configure 'counsel-read-directory-name
  2551. :display-transformer-fn #'ivy-read-file-transformer)
  2552. (defun counsel-cd ()
  2553. "Change the directory for the currently running Ivy grep-like command.
  2554. Works for `counsel-git-grep', `counsel-ag', etc."
  2555. (interactive)
  2556. (let ((input ivy-text)
  2557. (new-dir (counsel-read-directory-name "cd: ")))
  2558. (ivy-quit-and-run
  2559. (funcall (ivy-state-caller ivy-last) input new-dir))))
  2560. (defun counsel-grep-like-occur (cmd-template)
  2561. (unless (eq major-mode 'ivy-occur-grep-mode)
  2562. (ivy-occur-grep-mode)
  2563. (setq default-directory (ivy-state-directory ivy-last)))
  2564. (setq ivy-text
  2565. (and (string-match "\"\\(.*\\)\"" (buffer-name))
  2566. (match-string 1 (buffer-name))))
  2567. (let* ((cmd
  2568. (if (functionp cmd-template)
  2569. (funcall cmd-template ivy-text)
  2570. (let* ((command-args (counsel--split-command-args ivy-text))
  2571. (regex (counsel--grep-regex (cdr command-args)))
  2572. (switches (concat (car command-args)
  2573. (counsel--ag-extra-switches regex))))
  2574. (format cmd-template
  2575. (concat
  2576. switches
  2577. (shell-quote-argument regex))))))
  2578. (cands (counsel--split-string (shell-command-to-string cmd))))
  2579. (swiper--occur-insert-lines (mapcar #'counsel--normalize-grep-match cands))))
  2580. (defun counsel-ag-occur (&optional _cands)
  2581. "Generate a custom occur buffer for `counsel-ag'."
  2582. (counsel-grep-like-occur
  2583. counsel-ag-command))
  2584. ;;** `counsel-pt'
  2585. (defcustom counsel-pt-base-command "pt --nocolor --nogroup -e %s"
  2586. "Alternative to `counsel-ag-base-command' using pt."
  2587. :type 'string)
  2588. ;;;###autoload
  2589. (defun counsel-pt (&optional initial-input)
  2590. "Grep for a string in the current directory using pt.
  2591. INITIAL-INPUT can be given as the initial minibuffer input.
  2592. This uses `counsel-ag' with `counsel-pt-base-command' instead of
  2593. `counsel-ag-base-command'."
  2594. (interactive)
  2595. (let ((counsel-ag-base-command counsel-pt-base-command)
  2596. (counsel--grep-tool-look-around nil))
  2597. (counsel-ag initial-input :caller 'counsel-pt)))
  2598. (ivy-configure 'counsel-pt
  2599. :unwind-fn #'counsel--grep-unwind
  2600. :display-transformer-fn #'counsel-git-grep-transformer
  2601. :grep-p t)
  2602. ;;** `counsel-ack'
  2603. (defcustom counsel-ack-base-command
  2604. (concat
  2605. (file-name-nondirectory
  2606. (or (executable-find "ack-grep") "ack"))
  2607. " --nocolor --nogroup %s")
  2608. "Alternative to `counsel-ag-base-command' using ack."
  2609. :type 'string)
  2610. ;;;###autoload
  2611. (defun counsel-ack (&optional initial-input)
  2612. "Grep for a string in the current directory using ack.
  2613. INITIAL-INPUT can be given as the initial minibuffer input.
  2614. This uses `counsel-ag' with `counsel-ack-base-command' replacing
  2615. `counsel-ag-base-command'."
  2616. (interactive)
  2617. (let ((counsel-ag-base-command counsel-ack-base-command)
  2618. (counsel--grep-tool-look-around t))
  2619. (counsel-ag initial-input :caller 'counsel-ack)))
  2620. ;;** `counsel-rg'
  2621. (defcustom counsel-rg-base-command
  2622. (if (memq system-type '(ms-dos windows-nt))
  2623. "rg --with-filename --no-heading --line-number --path-separator / --color never %s ."
  2624. "rg --with-filename --no-heading --line-number --color never %s")
  2625. "Alternative to `counsel-ag-base-command' using ripgrep.
  2626. Note: don't use single quotes for the regex."
  2627. :type 'string)
  2628. (defun counsel--rg-targets ()
  2629. "Return a list of files to operate on, based on `dired-mode' marks."
  2630. (if (eq major-mode 'dired-mode)
  2631. (let ((files
  2632. (dired-get-marked-files 'no-dir nil nil t)))
  2633. (if (and (null (cdr files))
  2634. (not (when (string-match-p "\\*ivy-occur" (buffer-name))
  2635. (dired-toggle-marks)
  2636. (setq files (dired-get-marked-files 'no-dir))
  2637. (dired-toggle-marks)
  2638. t)))
  2639. ""
  2640. (concat
  2641. " "
  2642. (mapconcat #'shell-quote-argument (delq t files) " "))))
  2643. ""))
  2644. ;;;###autoload
  2645. (defun counsel-rg (&optional initial-input initial-directory extra-rg-args rg-prompt)
  2646. "Grep for a string in the current directory using rg.
  2647. INITIAL-INPUT can be given as the initial minibuffer input.
  2648. INITIAL-DIRECTORY, if non-nil, is used as the root directory for search.
  2649. EXTRA-RG-ARGS string, if non-nil, is appended to `counsel-rg-base-command'.
  2650. RG-PROMPT, if non-nil, is passed as `ivy-read' prompt argument.
  2651. Example input with inclusion and exclusion file patterns:
  2652. -g*.py -g!*test* -- ..."
  2653. (interactive)
  2654. (let ((counsel-ag-base-command
  2655. (concat counsel-rg-base-command (counsel--rg-targets)))
  2656. (counsel--grep-tool-look-around
  2657. (let ((rg (car (split-string counsel-rg-base-command)))
  2658. (switch "--pcre2"))
  2659. (and (eq 0 (call-process rg nil nil nil switch "--version"))
  2660. switch))))
  2661. (counsel-ag initial-input initial-directory extra-rg-args rg-prompt
  2662. :caller 'counsel-rg)))
  2663. (ivy-configure 'counsel-rg
  2664. :occur #'counsel-ag-occur
  2665. :unwind-fn #'counsel--grep-unwind
  2666. :display-transformer-fn #'counsel-git-grep-transformer
  2667. :grep-p t
  2668. :exit-codes '(1 "No matches found"))
  2669. ;;** `counsel-grep'
  2670. (defvar counsel-grep-map
  2671. (let ((map (make-sparse-keymap)))
  2672. (define-key map (kbd "C-l") 'ivy-call-and-recenter)
  2673. (define-key map (kbd "M-q") 'swiper-query-replace)
  2674. (define-key map (kbd "C-'") 'swiper-avy)
  2675. map))
  2676. (defcustom counsel-grep-base-command "grep -E -n -e %s %s"
  2677. "Format string used by `counsel-grep' to build a shell command.
  2678. It should contain two %-sequences (see function `format') to be
  2679. substituted by the search regexp and file, respectively. Neither
  2680. %-sequence should be contained in single quotes."
  2681. :type 'string)
  2682. (defvar counsel-grep-command nil)
  2683. (defun counsel-grep-function (string)
  2684. "Grep in the current directory for STRING."
  2685. (or
  2686. (ivy-more-chars)
  2687. (let ((regex (counsel--elisp-to-pcre
  2688. (setq ivy--old-re
  2689. (ivy--regex string)))))
  2690. (counsel--async-command
  2691. (format counsel-grep-command (shell-quote-argument regex)))
  2692. nil)))
  2693. (defvar counsel--grep-last-pos nil
  2694. "Store the last point and line that `counsel-grep-action' scrolled to.
  2695. This speeds up scrolling: instead of going to `point-min' and
  2696. `forward-line' with a huge arg (e.g. to scroll 50K lines), scroll
  2697. relative to the last position stored here.")
  2698. (defun counsel-grep-action (x)
  2699. "Go to candidate X."
  2700. (with-ivy-window
  2701. (swiper--cleanup)
  2702. (let ((default-directory
  2703. (file-name-directory
  2704. (ivy-state-directory ivy-last)))
  2705. file-name line-number)
  2706. (when (cond ((string-match "\\`\\([0-9]+\\):\\(.*\\)\\'" x)
  2707. (setq file-name (buffer-file-name (ivy-state-buffer ivy-last)))
  2708. (setq line-number (match-string-no-properties 1 x)))
  2709. ((string-match "\\`\\([^:]+\\):\\([0-9]+\\):\\(.*\\)\\'" x)
  2710. (setq file-name (match-string-no-properties 1 x))
  2711. (setq line-number (match-string-no-properties 2 x))))
  2712. ;; If the file buffer is already open, just get it. Prevent doing
  2713. ;; `find-file', as that file could have already been opened using
  2714. ;; `find-file-literally'.
  2715. (with-current-buffer (or (get-file-buffer file-name)
  2716. (find-file file-name))
  2717. (setq line-number (string-to-number line-number))
  2718. (if (and counsel--grep-last-pos (= (point) (car counsel--grep-last-pos)))
  2719. (forward-line (- line-number (cdr counsel--grep-last-pos)))
  2720. (goto-char (point-min))
  2721. (forward-line (1- line-number)))
  2722. (setq counsel--grep-last-pos (cons (point) line-number))
  2723. (when (re-search-forward (ivy--regex ivy-text t) (line-end-position) t)
  2724. (when swiper-goto-start-of-match
  2725. (goto-char (match-beginning 0))))
  2726. (run-hooks 'counsel-grep-post-action-hook)
  2727. (if (eq ivy-exit 'done)
  2728. (swiper--ensure-visible)
  2729. (isearch-range-invisible (line-beginning-position)
  2730. (line-end-position))
  2731. (swiper--add-overlays (ivy--regex ivy-text))))))))
  2732. (defun counsel-grep-occur (&optional _cands)
  2733. "Generate a custom occur buffer for `counsel-grep'."
  2734. (counsel-grep-like-occur
  2735. (format
  2736. "grep -niE %%s %s /dev/null"
  2737. (shell-quote-argument
  2738. (file-name-nondirectory
  2739. (buffer-file-name
  2740. (ivy-state-buffer ivy-last)))))))
  2741. (defvar counsel-grep-history nil
  2742. "History for `counsel-grep'.")
  2743. ;;;###autoload
  2744. (defun counsel-grep (&optional initial-input)
  2745. "Grep for a string in the file visited by the current buffer.
  2746. When non-nil, INITIAL-INPUT is the initial search pattern."
  2747. (interactive)
  2748. (unless buffer-file-name
  2749. (user-error "Current buffer is not visiting a file"))
  2750. (counsel-require-program counsel-grep-base-command)
  2751. (setq counsel-grep-command
  2752. (format counsel-grep-base-command
  2753. "%s" (shell-quote-argument
  2754. (file-name-nondirectory
  2755. buffer-file-name))))
  2756. (let ((default-directory (file-name-directory buffer-file-name))
  2757. (init-point (point))
  2758. res)
  2759. (unwind-protect
  2760. (setq res (ivy-read "grep: " #'counsel-grep-function
  2761. :initial-input initial-input
  2762. :dynamic-collection t
  2763. :require-match t
  2764. :preselect
  2765. (when (< (- (line-end-position) (line-beginning-position)) 300)
  2766. (format "%d:%s"
  2767. (line-number-at-pos)
  2768. (regexp-quote
  2769. (buffer-substring-no-properties
  2770. (line-beginning-position)
  2771. (line-end-position)))))
  2772. :keymap counsel-grep-map
  2773. :history 'counsel-grep-history
  2774. :re-builder #'ivy--regex
  2775. :action #'counsel-grep-action
  2776. :caller 'counsel-grep))
  2777. (unless res
  2778. (goto-char init-point)))))
  2779. (ivy-configure 'counsel-grep
  2780. :update-fn 'auto
  2781. :unwind-fn #'counsel--grep-unwind
  2782. :index-fn #'ivy-recompute-index-swiper-async
  2783. :occur #'counsel-grep-occur
  2784. :more-chars 2
  2785. :grep-p t
  2786. :exit-codes '(1 ""))
  2787. ;;;###autoload
  2788. (defun counsel-grep-backward (&optional initial-input)
  2789. "Grep for a string in the file visited by the current buffer going
  2790. backward similar to `swiper-backward'. When non-nil, INITIAL-INPUT is
  2791. the initial search pattern."
  2792. (interactive)
  2793. (let ((ivy-index-functions-alist
  2794. '((counsel-grep . ivy-recompute-index-swiper-async-backward))))
  2795. (counsel-grep initial-input)))
  2796. ;;** `counsel-grep-or-swiper'
  2797. (defcustom counsel-grep-swiper-limit 300000
  2798. "Buffer size threshold for `counsel-grep-or-swiper'.
  2799. When the number of characters in a buffer exceeds this threshold,
  2800. `counsel-grep' will be used instead of `swiper'."
  2801. :type 'integer)
  2802. (defcustom counsel-grep-use-swiper-p #'counsel-grep-use-swiper-p-default
  2803. "When this function returns non-nil, call `swiper', else `counsel-grep'."
  2804. :type '(choice
  2805. (const :tag "Rely on `counsel-grep-swiper-limit'."
  2806. counsel-grep-use-swiper-p-default)
  2807. (const :tag "Always use `counsel-grep'." ignore)
  2808. (function :tag "Custom")))
  2809. (defun counsel-grep-use-swiper-p-default ()
  2810. (<= (buffer-size)
  2811. (/ counsel-grep-swiper-limit
  2812. (if (eq major-mode 'org-mode) 4 1))))
  2813. ;;;###autoload
  2814. (defun counsel-grep-or-swiper (&optional initial-input)
  2815. "Call `swiper' for small buffers and `counsel-grep' for large ones.
  2816. When non-nil, INITIAL-INPUT is the initial search pattern."
  2817. (interactive)
  2818. (if (or (not buffer-file-name)
  2819. (buffer-narrowed-p)
  2820. (ignore-errors
  2821. (file-remote-p buffer-file-name))
  2822. (jka-compr-get-compression-info buffer-file-name)
  2823. (funcall counsel-grep-use-swiper-p))
  2824. (swiper initial-input)
  2825. (when (file-writable-p buffer-file-name)
  2826. (save-buffer))
  2827. (counsel-grep initial-input)))
  2828. ;;** `counsel-grep-or-swiper-backward'
  2829. ;;;###autoload
  2830. (defun counsel-grep-or-swiper-backward (&optional initial-input)
  2831. "Call `swiper-backward' for small buffers and `counsel-grep-backward' for
  2832. large ones. When non-nil, INITIAL-INPUT is the initial search pattern."
  2833. (interactive)
  2834. (let ((ivy-index-functions-alist
  2835. '((swiper . ivy-recompute-index-swiper-backward)
  2836. (counsel-grep . ivy-recompute-index-swiper-async-backward))))
  2837. (counsel-grep-or-swiper initial-input)))
  2838. ;;** `counsel-recoll'
  2839. (defun counsel-recoll-function (str)
  2840. "Run recoll for STR."
  2841. (or
  2842. (ivy-more-chars)
  2843. (progn
  2844. (counsel--async-command
  2845. (format "recoll -t -b %s"
  2846. (shell-quote-argument str)))
  2847. nil)))
  2848. ;; This command uses the recollq command line tool that comes together
  2849. ;; with the recoll (the document indexing database) source:
  2850. ;; https://www.lesbonscomptes.com/recoll/download.html
  2851. ;; You need to build it yourself (together with recoll):
  2852. ;; cd ./query && make && sudo cp recollq /usr/local/bin
  2853. ;; You can try the GUI version of recoll with:
  2854. ;; sudo apt-get install recoll
  2855. ;; Unfortunately, that does not install recollq.
  2856. ;;;###autoload
  2857. (defun counsel-recoll (&optional initial-input)
  2858. "Search for a string in the recoll database.
  2859. You'll be given a list of files that match.
  2860. Selecting a file will launch `swiper' for that file.
  2861. INITIAL-INPUT can be given as the initial minibuffer input."
  2862. (interactive)
  2863. (counsel-require-program "recoll")
  2864. (ivy-read "recoll: " 'counsel-recoll-function
  2865. :initial-input initial-input
  2866. :dynamic-collection t
  2867. :history 'counsel-git-grep-history
  2868. :action (lambda (x)
  2869. (when (string-match "file://\\(.*\\)\\'" x)
  2870. (let ((file-name (match-string 1 x)))
  2871. (find-file file-name)
  2872. (unless (string-match "pdf$" x)
  2873. (swiper ivy-text)))))
  2874. :caller 'counsel-recoll))
  2875. (ivy-configure 'counsel-recoll
  2876. :unwind-fn #'counsel-delete-process)
  2877. ;;* Org
  2878. ;;** `counsel-org-tag'
  2879. (defvar counsel-org-tags nil
  2880. "Store the current list of tags.")
  2881. (defvar org-outline-regexp)
  2882. (defvar org-indent-mode)
  2883. (defvar org-indent-indentation-per-level)
  2884. (defvar org-tags-column)
  2885. (declare-function org-get-tags-string "org")
  2886. (declare-function org-get-tags "org")
  2887. (declare-function org-make-tag-string "org")
  2888. (declare-function org-move-to-column "org-compat")
  2889. (defun counsel--org-make-tag-string ()
  2890. (if (fboundp #'org-make-tag-string)
  2891. ;; >= Org 9.2
  2892. (org-make-tag-string (counsel--org-get-tags))
  2893. (with-no-warnings
  2894. (org-get-tags-string))))
  2895. (defun counsel-org-change-tags (tags)
  2896. "Change tags of current org headline to TAGS."
  2897. (let ((current (counsel--org-make-tag-string))
  2898. (col (current-column))
  2899. level)
  2900. ;; Insert new tags at the correct column
  2901. (beginning-of-line 1)
  2902. (setq level (or (and (looking-at org-outline-regexp)
  2903. (- (match-end 0) (point) 1))
  2904. 1))
  2905. (cond
  2906. ((and (equal current "") (equal tags "")))
  2907. ((re-search-forward
  2908. (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$")
  2909. (line-end-position) t)
  2910. (if (equal tags "")
  2911. (delete-region
  2912. (match-beginning 0)
  2913. (match-end 0))
  2914. (goto-char (match-beginning 0))
  2915. (let* ((c0 (current-column))
  2916. ;; compute offset for the case of org-indent-mode active
  2917. (di (if (bound-and-true-p org-indent-mode)
  2918. (* (1- org-indent-indentation-per-level) (1- level))
  2919. 0))
  2920. (p0 (if (equal (char-before) ?*) (1+ (point)) (point)))
  2921. (tc (+ org-tags-column (if (> org-tags-column 0) (- di) di)))
  2922. (c1 (max (1+ c0) (if (> tc 0) tc (- (- tc) (string-width tags)))))
  2923. (rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags)))
  2924. (replace-match rpl t t)
  2925. (and c0 indent-tabs-mode (tabify p0 (point)))
  2926. tags)))
  2927. (t (error "Tags alignment failed")))
  2928. (org-move-to-column col)))
  2929. (defun counsel-org--set-tags ()
  2930. "Set tags of current org headline to `counsel-org-tags'."
  2931. (counsel-org-change-tags
  2932. (if counsel-org-tags
  2933. (format ":%s:"
  2934. (mapconcat #'identity counsel-org-tags ":"))
  2935. "")))
  2936. (defvar org-agenda-bulk-marked-entries)
  2937. (declare-function org-get-at-bol "org")
  2938. (declare-function org-agenda-error "org-agenda")
  2939. (defun counsel-org-tag-action (x)
  2940. "Add tag X to `counsel-org-tags'.
  2941. If X is already part of the list, remove it instead. Quit the selection if
  2942. X is selected by either `ivy-done', `ivy-alt-done' or `ivy-immediate-done',
  2943. otherwise continue prompting for tags."
  2944. (if (member x counsel-org-tags)
  2945. (progn
  2946. (setq counsel-org-tags (delete x counsel-org-tags)))
  2947. (unless (equal x "")
  2948. (setq counsel-org-tags (append counsel-org-tags (list x)))
  2949. (unless (member x ivy--all-candidates)
  2950. (setq ivy--all-candidates (append ivy--all-candidates (list x))))))
  2951. (let ((prompt (counsel-org-tag-prompt)))
  2952. (setf (ivy-state-prompt ivy-last) prompt)
  2953. (setq ivy--prompt (concat "%-4d " prompt)))
  2954. (cond ((memq this-command '(ivy-done
  2955. ivy-alt-done
  2956. ivy-immediate-done))
  2957. (if (eq major-mode 'org-agenda-mode)
  2958. (if (null org-agenda-bulk-marked-entries)
  2959. (let ((hdmarker (or (org-get-at-bol 'org-hd-marker)
  2960. (org-agenda-error))))
  2961. (with-current-buffer (marker-buffer hdmarker)
  2962. (goto-char hdmarker)
  2963. (counsel-org--set-tags)))
  2964. (let ((add-tags (copy-sequence counsel-org-tags)))
  2965. (dolist (m org-agenda-bulk-marked-entries)
  2966. (with-current-buffer (marker-buffer m)
  2967. (save-excursion
  2968. (goto-char m)
  2969. (setq counsel-org-tags
  2970. (delete-dups
  2971. (append (counsel--org-get-tags) add-tags)))
  2972. (counsel-org--set-tags))))))
  2973. (counsel-org--set-tags)))
  2974. ((eq this-command 'ivy-call)
  2975. (with-selected-window (active-minibuffer-window)
  2976. (delete-minibuffer-contents)))))
  2977. (defun counsel-org-tag-prompt ()
  2978. "Return prompt for `counsel-org-tag'."
  2979. (format "Tags (%s): "
  2980. (mapconcat #'identity counsel-org-tags ", ")))
  2981. (defvar org-setting-tags)
  2982. (defvar org-last-tags-completion-table)
  2983. (defvar org-tag-persistent-alist)
  2984. (defvar org-tag-alist)
  2985. (defvar org-complete-tags-always-offer-all-agenda-tags)
  2986. (declare-function org-at-heading-p "org")
  2987. (declare-function org-back-to-heading "org")
  2988. (declare-function org-get-buffer-tags "org")
  2989. (declare-function org-global-tags-completion-table "org")
  2990. (declare-function org-agenda-files "org")
  2991. (declare-function org-agenda-set-tags "org-agenda")
  2992. (declare-function org-tags-completion-function "org")
  2993. ;;;###autoload
  2994. (defun counsel--org-get-tags ()
  2995. (delete "" (condition-case nil
  2996. (org-get-tags nil t)
  2997. (error (org-get-tags)))))
  2998. ;;;###autoload
  2999. (defun counsel-org-tag ()
  3000. "Add or remove tags in `org-mode'."
  3001. (interactive)
  3002. (save-excursion
  3003. (if (eq major-mode 'org-agenda-mode)
  3004. (if org-agenda-bulk-marked-entries
  3005. (setq counsel-org-tags nil)
  3006. (let ((hdmarker (or (org-get-at-bol 'org-hd-marker)
  3007. (org-agenda-error))))
  3008. (with-current-buffer (marker-buffer hdmarker)
  3009. (goto-char hdmarker)
  3010. (setq counsel-org-tags (counsel--org-get-tags)))))
  3011. (unless (org-at-heading-p)
  3012. (org-back-to-heading t))
  3013. (setq counsel-org-tags (counsel--org-get-tags)))
  3014. (let ((org-last-tags-completion-table
  3015. (append (and (or org-complete-tags-always-offer-all-agenda-tags
  3016. (eq major-mode 'org-agenda-mode))
  3017. (org-global-tags-completion-table
  3018. (org-agenda-files)))
  3019. (unless (boundp 'org-current-tag-alist)
  3020. org-tag-persistent-alist)
  3021. (or (if (boundp 'org-current-tag-alist)
  3022. org-current-tag-alist
  3023. org-tag-alist)
  3024. (org-get-buffer-tags)))))
  3025. (ivy-read (counsel-org-tag-prompt)
  3026. (lambda (str _pred _action)
  3027. (delete-dups
  3028. (all-completions str #'org-tags-completion-function)))
  3029. :history 'org-tags-history
  3030. :action #'counsel-org-tag-action
  3031. :caller 'counsel-org-tag))))
  3032. (defvar org-version)
  3033. ;;;###autoload
  3034. (defun counsel-org-tag-agenda ()
  3035. "Set tags for the current agenda item."
  3036. (interactive)
  3037. (cl-letf (((symbol-function (if (version< org-version "9.2")
  3038. 'org-set-tags
  3039. 'org-set-tags-command))
  3040. #'counsel-org-tag))
  3041. (org-agenda-set-tags)))
  3042. (defcustom counsel-org-headline-display-tags nil
  3043. "If non-nil, display tags in matched `org-mode' headlines."
  3044. :type 'boolean)
  3045. (defcustom counsel-org-headline-display-todo nil
  3046. "If non-nil, display todo keywords in matched `org-mode' headlines."
  3047. :type 'boolean)
  3048. (defcustom counsel-org-headline-display-priority nil
  3049. "If non-nil, display priorities in matched `org-mode' headlines."
  3050. :type 'boolean)
  3051. (declare-function org-get-heading "org")
  3052. (declare-function org-goto-marker-or-bmk "org")
  3053. (declare-function outline-next-heading "outline")
  3054. ;;;###autoload
  3055. (defalias 'counsel-org-goto #'counsel-outline)
  3056. (defcustom counsel-org-goto-all-outline-path-prefix nil
  3057. "Prefix for outline candidates in `counsel-org-goto-all'."
  3058. :type '(choice
  3059. (const :tag "None" nil)
  3060. (const :tag "File name" file-name)
  3061. (const :tag "File name (nondirectory part)" file-name-nondirectory)
  3062. (const :tag "Buffer name" buffer-name)))
  3063. (defun counsel-org-goto-all--outline-path-prefix ()
  3064. (cl-case counsel-org-goto-all-outline-path-prefix
  3065. (file-name buffer-file-name)
  3066. (file-name-nondirectory (file-name-nondirectory buffer-file-name))
  3067. (buffer-name (buffer-name))))
  3068. (defvar counsel-outline-settings
  3069. '((emacs-lisp-mode
  3070. :outline-regexp ";;[;*]+[\s\t]+"
  3071. :outline-level counsel-outline-level-emacs-lisp)
  3072. (org-mode
  3073. :outline-title counsel-outline-title-org
  3074. :action counsel-org-goto-action
  3075. :history counsel-org-goto-history
  3076. :caller counsel-org-goto)
  3077. ;; markdown-mode package
  3078. (markdown-mode
  3079. :outline-title counsel-outline-title-markdown)
  3080. ;; Built-in mode or AUCTeX package
  3081. (latex-mode
  3082. :outline-title counsel-outline-title-latex))
  3083. "Alist mapping major modes to their `counsel-outline' settings.
  3084. Each entry is a pair (MAJOR-MODE . PLIST). `counsel-outline'
  3085. checks whether an entry exists for the current buffer's
  3086. MAJOR-MODE and, if so, loads the settings specified by PLIST
  3087. instead of the default settings. The following settings are
  3088. recognized:
  3089. - `:outline-regexp' is a regexp to match the beginning of an
  3090. outline heading. It is only checked at the start of a line and
  3091. so need not start with \"^\".
  3092. Defaults to the value of the variable `outline-regexp'.
  3093. - `:outline-level' is a function of no arguments which computes
  3094. the level of an outline heading. It is called with point at
  3095. the beginning of `outline-regexp' and with the match data
  3096. corresponding to `outline-regexp'.
  3097. Defaults to the value of the variable `outline-level'.
  3098. - `:outline-title' is a function of no arguments which returns
  3099. the title of an outline heading. It is called with point at
  3100. the end of `outline-regexp' and with the match data
  3101. corresponding to `outline-regexp'.
  3102. Defaults to the function `counsel-outline-title'.
  3103. - `:action' is a function of one argument, the selected outline
  3104. heading to jump to. This setting corresponds directly to its
  3105. eponymous `ivy-read' keyword, as used by `counsel-outline', so
  3106. the type of the function's argument depends on the value
  3107. returned by `counsel-outline-candidates'.
  3108. Defaults to the function `counsel-outline-action'.
  3109. - `:history' is a history list, usually a symbol representing a
  3110. history list variable. It corresponds directly to its
  3111. eponymous `ivy-read' keyword, as used by `counsel-outline'.
  3112. Defaults to the symbol `counsel-outline-history'.
  3113. - `:caller' is a symbol to uniquely identify the caller to
  3114. `ivy-read'. It corresponds directly to its eponymous
  3115. `ivy-read' keyword, as used by `counsel-outline'.
  3116. Defaults to the symbol `counsel-outline'.
  3117. - `:display-style' overrides the variable
  3118. `counsel-outline-display-style'.
  3119. - `:path-separator' overrides the variable
  3120. `counsel-outline-path-separator'.
  3121. - `:face-style' overrides the variable
  3122. `counsel-outline-face-style'.
  3123. - `:custom-faces' overrides the variable
  3124. `counsel-outline-custom-faces'.")
  3125. ;;;###autoload
  3126. (defun counsel-org-goto-all ()
  3127. "Go to a different location in any org file."
  3128. (interactive)
  3129. (let (entries)
  3130. (dolist (b (buffer-list))
  3131. (with-current-buffer b
  3132. (when (derived-mode-p 'org-mode)
  3133. (setq entries
  3134. (nconc entries
  3135. (counsel-outline-candidates
  3136. (cdr (assq 'org-mode counsel-outline-settings))
  3137. (counsel-org-goto-all--outline-path-prefix)))))))
  3138. (ivy-read "Goto: " entries
  3139. :history 'counsel-org-goto-history
  3140. :action #'counsel-org-goto-action
  3141. :caller 'counsel-org-goto-all)))
  3142. (defun counsel-org-goto-action (x)
  3143. "Go to headline in candidate X."
  3144. (org-goto-marker-or-bmk (cdr x)))
  3145. (defun counsel--org-get-heading-args ()
  3146. "Return list of arguments for `org-get-heading'.
  3147. Try to return the right number of arguments for the current Org
  3148. version. Argument values are based on the
  3149. `counsel-org-headline-display-*' user options."
  3150. (nbutlast (mapcar #'not (list counsel-org-headline-display-tags
  3151. counsel-org-headline-display-todo
  3152. counsel-org-headline-display-priority))
  3153. (if (if (fboundp 'func-arity)
  3154. (< (cdr (func-arity #'org-get-heading)) 3)
  3155. (version< org-version "9.1.1"))
  3156. 1 0)))
  3157. ;;** `counsel-org-file'
  3158. (declare-function org-attach-dir "org-attach")
  3159. (declare-function org-attach-file-list "org-attach")
  3160. (defvar org-attach-directory)
  3161. (defun counsel-org-files ()
  3162. "Return list of all files under current Org attachment directories.
  3163. Filenames returned are relative to `default-directory'. For each
  3164. attachment directory associated with the current buffer, all
  3165. contained files are listed, so the return value could conceivably
  3166. include attachments of other Org buffers."
  3167. (require 'org-attach)
  3168. (let (dirs)
  3169. (save-excursion
  3170. (goto-char (point-min))
  3171. (while (re-search-forward "^:\\(ATTACH_DIR\\|ID\\):[\t ]+\\(.*\\)$" nil t)
  3172. (let ((dir (org-attach-dir)))
  3173. (when dir
  3174. (push dir dirs)))))
  3175. (cl-mapcan
  3176. (lambda (dir)
  3177. (mapcar (lambda (file)
  3178. (file-relative-name (expand-file-name file dir)))
  3179. (org-attach-file-list dir)))
  3180. (nreverse dirs))))
  3181. ;;;###autoload
  3182. (defun counsel-org-file ()
  3183. "Browse all attachments for current Org file."
  3184. (interactive)
  3185. (ivy-read "file: " (counsel-org-files)
  3186. :action #'counsel-locate-action-dired
  3187. :caller 'counsel-org-file))
  3188. ;;** `counsel-org-entity'
  3189. (defvar org-entities)
  3190. (defvar org-entities-user)
  3191. ;;;###autoload
  3192. (defun counsel-org-entity ()
  3193. "Complete Org entities using Ivy."
  3194. (interactive)
  3195. (require 'org)
  3196. (ivy-read "Entity: " (cl-loop for element in (append org-entities org-entities-user)
  3197. unless (stringp element)
  3198. collect (cons
  3199. (format "%20s | %20s | %20s | %s"
  3200. (cl-first element) ; name
  3201. (cl-second element) ; latex
  3202. (cl-fourth element) ; html
  3203. (cl-seventh element)) ; utf-8
  3204. element))
  3205. :require-match t
  3206. :action '(1
  3207. ("u" (lambda (candidate)
  3208. (insert (cl-seventh (cdr candidate)))) "utf-8")
  3209. ("o" (lambda (candidate)
  3210. (insert "\\" (cl-first (cdr candidate)))) "org-entity")
  3211. ("l" (lambda (candidate)
  3212. (insert (cl-second (cdr candidate)))) "latex")
  3213. ("h" (lambda (candidate)
  3214. (insert (cl-fourth (cdr candidate)))) "html")
  3215. ("a" (lambda (candidate)
  3216. (insert (cl-fifth (cdr candidate)))) "ascii")
  3217. ("L" (lambda (candidate)
  3218. (insert (cl-sixth (cdr candidate))) "Latin-1")))))
  3219. ;;** `counsel-org-capture'
  3220. (defvar org-capture-templates)
  3221. (defvar org-capture-templates-contexts)
  3222. (declare-function org-contextualize-keys "org")
  3223. (declare-function org-capture-goto-last-stored "org-capture")
  3224. (declare-function org-capture-goto-target "org-capture")
  3225. (declare-function org-capture-upgrade-templates "org-capture")
  3226. ;;;###autoload
  3227. (defun counsel-org-capture ()
  3228. "Capture something."
  3229. (interactive)
  3230. (require 'org-capture)
  3231. (ivy-read "Capture template: "
  3232. (delq nil
  3233. (mapcar
  3234. (lambda (x)
  3235. (when (> (length x) 2)
  3236. (format "%-5s %s" (nth 0 x) (nth 1 x))))
  3237. ;; We build the list of capture templates as in
  3238. ;; `org-capture-select-template':
  3239. (or (org-contextualize-keys
  3240. (org-capture-upgrade-templates org-capture-templates)
  3241. org-capture-templates-contexts)
  3242. '(("t" "Task" entry (file+headline "" "Tasks")
  3243. "* TODO %?\n %u\n %a")))))
  3244. :require-match t
  3245. :action (lambda (x)
  3246. (org-capture nil (car (split-string x))))
  3247. :caller 'counsel-org-capture))
  3248. (ivy-configure 'counsel-org-capture
  3249. :initial-input "^")
  3250. (ivy-set-actions
  3251. 'counsel-org-capture
  3252. `(("t" ,(lambda (x)
  3253. (org-capture-goto-target (car (split-string x))))
  3254. "go to target")
  3255. ("l" ,(lambda (_x)
  3256. (org-capture-goto-last-stored))
  3257. "go to last stored")
  3258. ("p" ,(lambda (x)
  3259. (org-capture 0 (car (split-string x))))
  3260. "insert template at point")
  3261. ("c" ,(lambda (_x)
  3262. (customize-variable 'org-capture-templates))
  3263. "customize org-capture-templates")))
  3264. ;;** `counsel-org-agenda-headlines'
  3265. (defvar org-odd-levels-only)
  3266. (declare-function org-set-startup-visibility "org")
  3267. (declare-function org-show-entry "org")
  3268. (declare-function org-map-entries "org")
  3269. (declare-function org-heading-components "org")
  3270. (defun counsel-org-agenda-headlines-action-goto (headline)
  3271. "Go to the `org-mode' agenda HEADLINE."
  3272. (find-file (nth 1 headline))
  3273. (org-set-startup-visibility)
  3274. (goto-char (nth 2 headline))
  3275. (org-show-entry))
  3276. (ivy-set-actions
  3277. 'counsel-org-agenda-headlines
  3278. '(("g" counsel-org-agenda-headlines-action-goto "goto headline")))
  3279. (defvar counsel-org-agenda-headlines-history nil
  3280. "History for `counsel-org-agenda-headlines'.")
  3281. (defcustom counsel-outline-display-style 'path
  3282. "The style used when displaying matched outline headings.
  3283. If `headline', the title is displayed with leading stars
  3284. indicating the outline level.
  3285. If `path', the path hierarchy is displayed. For each entry the
  3286. title is shown. Entries are separated with
  3287. `counsel-outline-path-separator'.
  3288. If `title' or any other value, only the title of the heading is
  3289. displayed.
  3290. For displaying tags and TODO keywords in `org-mode' buffers, see
  3291. `counsel-org-headline-display-tags' and
  3292. `counsel-org-headline-display-todo', respectively."
  3293. :type '(choice
  3294. (const :tag "Title only" title)
  3295. (const :tag "Headline" headline)
  3296. (const :tag "Path" path)))
  3297. (defcustom counsel-outline-path-separator "/"
  3298. "String separating path entries in matched outline headings.
  3299. This variable has no effect unless
  3300. `counsel-outline-display-style' is set to `path'."
  3301. :type 'string)
  3302. (declare-function org-get-outline-path "org")
  3303. (defun counsel-org-agenda-headlines--candidates ()
  3304. "Return a list of completion candidates for `counsel-org-agenda-headlines'."
  3305. (org-map-entries
  3306. (lambda ()
  3307. (let* ((components (org-heading-components))
  3308. (level (and (eq counsel-outline-display-style 'headline)
  3309. (make-string
  3310. (if org-odd-levels-only
  3311. (nth 1 components)
  3312. (nth 0 components))
  3313. ?*)))
  3314. (todo (and counsel-org-headline-display-todo
  3315. (nth 2 components)))
  3316. (path (and (eq counsel-outline-display-style 'path)
  3317. (org-get-outline-path)))
  3318. (priority (and counsel-org-headline-display-priority
  3319. (nth 3 components)))
  3320. (text (nth 4 components))
  3321. (tags (and counsel-org-headline-display-tags
  3322. (nth 5 components))))
  3323. (list
  3324. (mapconcat
  3325. 'identity
  3326. (cl-remove-if 'null
  3327. (list
  3328. level
  3329. todo
  3330. (and priority (format "[#%c]" priority))
  3331. (mapconcat 'identity
  3332. (append path (list text))
  3333. counsel-outline-path-separator)
  3334. tags))
  3335. " ")
  3336. buffer-file-name
  3337. (point))))
  3338. nil
  3339. 'agenda))
  3340. ;;;###autoload
  3341. (defun counsel-org-agenda-headlines ()
  3342. "Choose from headers of `org-mode' files in the agenda."
  3343. (interactive)
  3344. (require 'org)
  3345. (let ((minibuffer-allow-text-properties t))
  3346. (ivy-read "Org headline: "
  3347. (counsel-org-agenda-headlines--candidates)
  3348. :action #'counsel-org-agenda-headlines-action-goto
  3349. :history 'counsel-org-agenda-headlines-history
  3350. :caller 'counsel-org-agenda-headlines)))
  3351. ;;* Misc. Emacs
  3352. ;;** `counsel-mark-ring'
  3353. (defface counsel--mark-ring-highlight
  3354. '((t (:inherit highlight)))
  3355. "Face for current `counsel-mark-ring' line."
  3356. :group 'ivy-faces)
  3357. (defvar counsel--mark-ring-overlay nil
  3358. "Internal overlay to highlight line by candidate of `counsel-mark-ring'.")
  3359. (defun counsel--mark-ring-add-highlight ()
  3360. "Add highlight to current line."
  3361. (setq counsel--mark-ring-overlay
  3362. (make-overlay (line-beginning-position) (1+ (line-end-position))))
  3363. (with-ivy-window
  3364. (overlay-put counsel--mark-ring-overlay 'face
  3365. 'counsel--mark-ring-highlight)))
  3366. (defun counsel--mark-ring-delete-highlight ()
  3367. "If `counsel-mark-ring' have highlight, delete highlight."
  3368. (if counsel--mark-ring-overlay (delete-overlay counsel--mark-ring-overlay)))
  3369. (defvar counsel--mark-ring-calling-point 0
  3370. "Internal variable to remember calling position.")
  3371. (defun counsel--mark-ring-unwind ()
  3372. "Return back to calling position of `counsel-mark-ring'."
  3373. (goto-char counsel--mark-ring-calling-point)
  3374. (counsel--mark-ring-delete-highlight))
  3375. (defun counsel--mark-ring-update-fn ()
  3376. "Show preview by candidate."
  3377. (let ((pos (get-text-property 0 'point (ivy-state-current ivy-last))))
  3378. (counsel--mark-ring-delete-highlight)
  3379. (with-ivy-window
  3380. (goto-char pos)
  3381. (counsel--mark-ring-add-highlight))))
  3382. ;;;###autoload
  3383. (defun counsel-mark-ring ()
  3384. "Browse `mark-ring' interactively.
  3385. Obeys `widen-automatically', which see."
  3386. (interactive)
  3387. (let* ((counsel--mark-ring-calling-point (point))
  3388. (width (length (number-to-string (line-number-at-pos (point-max)))))
  3389. (fmt (format "%%%dd %%s" width))
  3390. (make-candidate
  3391. (lambda (mark)
  3392. (goto-char (marker-position mark))
  3393. (let ((linum (line-number-at-pos))
  3394. (line (buffer-substring
  3395. (line-beginning-position) (line-end-position))))
  3396. (propertize (format fmt linum line) 'point (point)))))
  3397. (marks (copy-sequence mark-ring))
  3398. (marks (delete-dups marks))
  3399. (marks
  3400. ;; mark-marker is empty?
  3401. (if (equal (mark-marker) (make-marker))
  3402. marks
  3403. (cons (copy-marker (mark-marker)) marks)))
  3404. (cands
  3405. ;; Widen, both to save `line-number-at-pos' the trouble
  3406. ;; and for `buffer-substring' to work.
  3407. (save-excursion
  3408. (save-restriction
  3409. (widen)
  3410. (mapcar make-candidate marks)))))
  3411. (if cands
  3412. (ivy-read "Mark: " cands
  3413. :require-match t
  3414. :action (lambda (cand)
  3415. (let ((pos (get-text-property 0 'point cand)))
  3416. (when pos
  3417. (unless (<= (point-min) pos (point-max))
  3418. (if widen-automatically
  3419. (widen)
  3420. (error "\
  3421. Position of selected mark outside accessible part of buffer")))
  3422. (goto-char pos))))
  3423. :caller 'counsel-mark-ring)
  3424. (message "Mark ring is empty"))))
  3425. (ivy-configure 'counsel-mark-ring
  3426. :update-fn #'counsel--mark-ring-update-fn
  3427. :unwind-fn #'counsel--mark-ring-unwind
  3428. :sort-fn #'ivy-string<)
  3429. ;;** `counsel-package'
  3430. (defvar package--initialized)
  3431. (defvar package-alist)
  3432. (defvar package-archive-contents)
  3433. (defvar package-archives)
  3434. (defvar package-user-dir)
  3435. (declare-function package-installed-p "package")
  3436. (declare-function package-delete "package")
  3437. (declare-function package-desc-extras "package")
  3438. (defvar counsel-package-history nil
  3439. "History for `counsel-package'.")
  3440. (defun counsel--package-candidates ()
  3441. "Return completion alist for `counsel-package'."
  3442. (unless package--initialized
  3443. (package-initialize t))
  3444. (if (or (not package-archive-contents)
  3445. (cl-find-if (lambda (package-archive)
  3446. (let ((fname
  3447. (format
  3448. "%s/archives/%s/archive-contents"
  3449. package-user-dir (car package-archive))))
  3450. (or (not (file-exists-p fname))
  3451. (counsel-file-stale-p fname (* 4 60 60)))))
  3452. package-archives))
  3453. (package-refresh-contents))
  3454. (sort (mapcar (lambda (entry)
  3455. (cons (let ((pkg (car entry)))
  3456. (concat (if (package-installed-p pkg) "-" "+")
  3457. (symbol-name pkg)))
  3458. entry))
  3459. package-archive-contents)
  3460. #'counsel--package-sort))
  3461. ;;;###autoload
  3462. (defun counsel-package ()
  3463. "Install or delete packages.
  3464. Packages not currently installed are prefixed with \"+\", and
  3465. selecting one of these will try to install it.
  3466. Packages currently installed are prefixed with \"-\", and
  3467. selecting one of these will try to delete it.
  3468. Additional actions:\\<ivy-minibuffer-map>
  3469. \\[ivy-dispatching-done] d: Describe package
  3470. \\[ivy-dispatching-done] h: Visit package's homepage"
  3471. (interactive)
  3472. (require 'package)
  3473. (ivy-read "Packages (install +pkg or delete -pkg): "
  3474. (counsel--package-candidates)
  3475. :action #'counsel-package-action
  3476. :require-match t
  3477. :history 'counsel-package-history
  3478. :caller 'counsel-package))
  3479. (cl-pushnew '(counsel-package . "^+") ivy-initial-inputs-alist :key #'car)
  3480. (defun counsel-package-action (package)
  3481. "Delete or install PACKAGE."
  3482. (setq package (cadr package))
  3483. (if (package-installed-p package)
  3484. (package-delete (cadr (assq package package-alist)))
  3485. (package-install package)))
  3486. (defun counsel-package-action-describe (package)
  3487. "Call `describe-package' on PACKAGE."
  3488. (describe-package (cadr package)))
  3489. (defun counsel-package-action-homepage (package)
  3490. "Open homepage for PACKAGE in a WWW browser."
  3491. (let ((url (cdr (assq :url (package-desc-extras (nth 2 package))))))
  3492. (if url
  3493. (browse-url url)
  3494. (message "No homepage specified for package `%s'" (nth 1 package)))))
  3495. (defun counsel--package-sort (a b)
  3496. "Sort function for `counsel-package' candidates."
  3497. (let* ((a (car a))
  3498. (b (car b))
  3499. (a-inst (= (string-to-char a) ?+))
  3500. (b-inst (= (string-to-char b) ?+)))
  3501. (or (and a-inst (not b-inst))
  3502. (and (eq a-inst b-inst) (string-lessp a b)))))
  3503. (ivy-set-actions
  3504. 'counsel-package
  3505. '(("d" counsel-package-action-describe "describe package")
  3506. ("h" counsel-package-action-homepage "open package homepage")))
  3507. ;;** `counsel-tmm'
  3508. (defvar tmm-km-list nil)
  3509. (declare-function tmm-get-keymap "tmm")
  3510. (declare-function tmm--completion-table "tmm")
  3511. (declare-function tmm-get-keybind "tmm")
  3512. (defun counsel-tmm-prompt (menu)
  3513. "Select and call an item from the MENU keymap."
  3514. (let (out
  3515. choice
  3516. chosen-string)
  3517. (setq tmm-km-list nil)
  3518. (map-keymap (lambda (k v) (tmm-get-keymap (cons k v))) menu)
  3519. (setq tmm-km-list (nreverse tmm-km-list))
  3520. (setq out (ivy-read "Menu bar: " (tmm--completion-table tmm-km-list)
  3521. :require-match t))
  3522. (setq choice (cdr (assoc out tmm-km-list)))
  3523. (setq chosen-string (car choice))
  3524. (setq choice (cdr choice))
  3525. (cond ((keymapp choice)
  3526. (counsel-tmm-prompt choice))
  3527. ((and choice chosen-string)
  3528. (setq last-command-event chosen-string)
  3529. (call-interactively choice)))))
  3530. (defvar tmm-table-undef)
  3531. ;;;###autoload
  3532. (defun counsel-tmm ()
  3533. "Text-mode emulation of looking and choosing from a menu bar."
  3534. (interactive)
  3535. (require 'tmm)
  3536. (run-hooks 'menu-bar-update-hook)
  3537. (setq tmm-table-undef nil)
  3538. (counsel-tmm-prompt (tmm-get-keybind [menu-bar])))
  3539. ;;** `counsel-yank-pop'
  3540. (defcustom counsel-yank-pop-truncate-radius 2
  3541. "Number of context lines around `counsel-yank-pop' candidates."
  3542. :type 'integer)
  3543. (defun counsel--yank-pop-truncate (str)
  3544. "Truncate STR for use in `counsel-yank-pop'."
  3545. (condition-case nil
  3546. (let* ((lines (split-string str "\n" t))
  3547. (n (length lines))
  3548. (re (ivy-re-to-str ivy--old-re))
  3549. (first-match (cl-position-if
  3550. (lambda (s) (string-match re s))
  3551. lines))
  3552. (beg (max 0 (- first-match
  3553. counsel-yank-pop-truncate-radius)))
  3554. (end (min n (+ first-match
  3555. counsel-yank-pop-truncate-radius
  3556. 1)))
  3557. (seq (cl-subseq lines beg end)))
  3558. (if (null first-match)
  3559. (error "Could not match %s" str)
  3560. (when (> beg 0)
  3561. (setcar seq (concat "[...] " (car seq))))
  3562. (when (< end n)
  3563. (setcar (last seq)
  3564. (concat (car (last seq)) " [...]")))
  3565. (mapconcat #'identity seq "\n")))
  3566. (error str)))
  3567. (defcustom counsel-yank-pop-separator "\n"
  3568. "Separator for the kill ring strings in `counsel-yank-pop'."
  3569. :type '(choice
  3570. (const :tag "Plain" "\n")
  3571. (const :tag "Dashes" "\n----\n")
  3572. string))
  3573. (defun counsel--yank-pop-format-function (cand-pairs)
  3574. "Transform CAND-PAIRS into a string for `counsel-yank-pop'."
  3575. (ivy--format-function-generic
  3576. (lambda (str)
  3577. (mapconcat
  3578. (lambda (s)
  3579. (ivy--add-face s 'ivy-current-match))
  3580. (split-string
  3581. (counsel--yank-pop-truncate str) "\n" t)
  3582. "\n"))
  3583. (lambda (str)
  3584. (counsel--yank-pop-truncate str))
  3585. cand-pairs
  3586. (propertize counsel-yank-pop-separator 'face 'ivy-separator)))
  3587. (defun counsel--yank-pop-position (s)
  3588. "Return position of S in `kill-ring' relative to last yank."
  3589. (or (cl-position s kill-ring-yank-pointer :test #'equal-including-properties)
  3590. (cl-position s kill-ring-yank-pointer :test #'equal)
  3591. (+ (or (cl-position s kill-ring :test #'equal-including-properties)
  3592. (cl-position s kill-ring :test #'equal))
  3593. (- (length kill-ring-yank-pointer)
  3594. (length kill-ring)))))
  3595. (defun counsel-string-non-blank-p (s)
  3596. "Return non-nil if S includes non-blank characters.
  3597. Newlines and carriage returns are considered blank."
  3598. (not (string-match-p "\\`[\n\r[:blank:]]*\\'" s)))
  3599. (defcustom counsel-yank-pop-filter #'counsel-string-non-blank-p
  3600. "Unary filter function applied to `counsel-yank-pop' candidates.
  3601. All elements of `kill-ring' for which this function returns nil
  3602. will be destructively removed from `kill-ring' before completion.
  3603. All blank strings are deleted from `kill-ring' by default."
  3604. :type '(radio
  3605. (function-item counsel-string-non-blank-p)
  3606. (function-item identity)
  3607. (function :tag "Other")))
  3608. (defun counsel--yank-pop-kills ()
  3609. "Return filtered `kill-ring' for `counsel-yank-pop' completion.
  3610. Both `kill-ring' and `kill-ring-yank-pointer' may be
  3611. destructively modified to eliminate duplicates under
  3612. `equal-including-properties', satisfy `counsel-yank-pop-filter',
  3613. and incorporate `interprogram-paste-function'."
  3614. ;; Protect against `kill-ring' and result of
  3615. ;; `interprogram-paste-function' both being nil
  3616. (ignore-errors (current-kill 0))
  3617. ;; Keep things consistent with the rest of Emacs
  3618. (dolist (sym '(kill-ring kill-ring-yank-pointer))
  3619. (set sym (cl-delete-duplicates
  3620. (cl-delete-if-not counsel-yank-pop-filter (symbol-value sym))
  3621. :test #'equal-including-properties :from-end t)))
  3622. kill-ring)
  3623. (defcustom counsel-yank-pop-after-point nil
  3624. "Whether `counsel-yank-pop' yanks after point.
  3625. Nil means `counsel-yank-pop' puts point at the end of the yanked
  3626. text and mark at its beginning, as per the default \\[yank].
  3627. Non-nil means `counsel-yank-pop' swaps the resulting point and
  3628. mark, as per \\[universal-argument] \\[yank]."
  3629. :type 'boolean)
  3630. (defun counsel-yank-pop-action (s)
  3631. "Like `yank-pop', but insert the kill corresponding to S.
  3632. Signal a `buffer-read-only' error if called from a read-only
  3633. buffer position."
  3634. (with-ivy-window
  3635. (barf-if-buffer-read-only)
  3636. (setq last-command 'yank)
  3637. (setq yank-window-start (window-start))
  3638. (condition-case nil
  3639. ;; Avoid unexpected additions to `kill-ring'
  3640. (let (interprogram-paste-function)
  3641. (yank-pop (counsel--yank-pop-position s)))
  3642. (error
  3643. (insert s)))
  3644. (when (funcall (if counsel-yank-pop-after-point #'> #'<)
  3645. (point) (mark t))
  3646. (exchange-point-and-mark t))))
  3647. (defun counsel-yank-pop-action-remove (s)
  3648. "Remove all occurrences of S from the kill ring."
  3649. (dolist (sym '(kill-ring kill-ring-yank-pointer))
  3650. (set sym (cl-delete s (symbol-value sym)
  3651. :test #'equal-including-properties)))
  3652. ;; Update collection and preselect for next `ivy-call'
  3653. (setf (ivy-state-collection ivy-last) kill-ring)
  3654. (setf (ivy-state-preselect ivy-last)
  3655. (nth (min ivy--index (1- (length kill-ring)))
  3656. kill-ring))
  3657. (ivy--reset-state ivy-last))
  3658. (defun counsel-yank-pop-action-rotate (s)
  3659. "Rotate the yanking point to S in the kill ring.
  3660. See `current-kill' for how this interacts with the window system
  3661. selection."
  3662. (let ((i (counsel--yank-pop-position s)))
  3663. ;; Avoid unexpected additions to `kill-ring'
  3664. (let (interprogram-paste-function)
  3665. (setf (ivy-state-preselect ivy-last) (current-kill i)))
  3666. ;; Manually change window system selection because `current-kill' won't
  3667. (when (and (zerop i)
  3668. yank-pop-change-selection
  3669. interprogram-cut-function)
  3670. (funcall interprogram-cut-function (car kill-ring-yank-pointer))))
  3671. (ivy--reset-state ivy-last))
  3672. (defcustom counsel-yank-pop-preselect-last nil
  3673. "Whether `counsel-yank-pop' preselects the last kill by default.
  3674. The command `counsel-yank-pop' always preselects the same kill
  3675. that `yank-pop' would have inserted, given the same prefix
  3676. argument.
  3677. When `counsel-yank-pop-preselect-last' is nil (the default), the
  3678. prefix argument of `counsel-yank-pop' defaults to 1 (as per
  3679. `yank-pop'), which causes the next-to-last kill to be
  3680. preselected. Otherwise, the prefix argument defaults to 0, which
  3681. results in the most recent kill being preselected."
  3682. :type 'boolean)
  3683. (autoload 'xor "array")
  3684. ;;;###autoload
  3685. (defun counsel-yank-pop (&optional arg)
  3686. "Ivy replacement for `yank-pop'.
  3687. With a plain prefix argument (\\[universal-argument]),
  3688. temporarily toggle the value of `counsel-yank-pop-after-point'.
  3689. Any other value of ARG has the same meaning as in `yank-pop', but
  3690. `counsel-yank-pop-preselect-last' determines its default value.
  3691. See also `counsel-yank-pop-filter' for how to filter candidates.
  3692. Note: Duplicate elements of `kill-ring' are always deleted."
  3693. ;; Do not specify `*' to allow browsing `kill-ring' in read-only buffers
  3694. (interactive "P")
  3695. (let ((kills (or (counsel--yank-pop-kills)
  3696. (error "Kill ring is empty or blank")))
  3697. (preselect (let (interprogram-paste-function)
  3698. (current-kill (cond ((nlistp arg)
  3699. (prefix-numeric-value arg))
  3700. (counsel-yank-pop-preselect-last 0)
  3701. (t 1))
  3702. t)))
  3703. (counsel-yank-pop-after-point
  3704. (xor (consp arg) counsel-yank-pop-after-point)))
  3705. (unless (eq last-command 'yank)
  3706. (push-mark))
  3707. (ivy-read "kill-ring: " kills
  3708. :require-match t
  3709. :preselect preselect
  3710. :action #'counsel-yank-pop-action
  3711. :caller 'counsel-yank-pop)))
  3712. (ivy-configure 'counsel-yank-pop
  3713. :height 5
  3714. :format-fn #'counsel--yank-pop-format-function)
  3715. (ivy-set-actions
  3716. 'counsel-yank-pop
  3717. '(("d" counsel-yank-pop-action-remove "delete")
  3718. ("r" counsel-yank-pop-action-rotate "rotate")))
  3719. ;;** `counsel-register'
  3720. (defvar counsel-register-actions
  3721. '(("\\`buffer position" . jump-to-register)
  3722. ("\\`text" . insert-register)
  3723. ("\\`rectangle" . insert-register)
  3724. ("\\`window configuration" . jump-to-register)
  3725. ("\\`frame configuration" . jump-to-register)
  3726. ("\\`[-+]?[0-9]+\\(?:\\.[0-9]\\)?\\'" . insert-register)
  3727. ("\\`the file" . jump-to-register)
  3728. ("\\`keyboard macro" . jump-to-register)
  3729. ("\\`file-query" . jump-to-register))
  3730. "Alist of (REGEXP . FUNCTION) pairs for `counsel-register'.
  3731. Selecting a register whose description matches REGEXP specifies
  3732. FUNCTION as the action to take on the register.")
  3733. (defvar counsel-register-history nil
  3734. "History for `counsel-register'.")
  3735. (defun counsel-register-action (register)
  3736. "Default action for `counsel-register'.
  3737. Call a function on REGISTER. The function is determined by
  3738. matching the register's value description against a regexp in
  3739. `counsel-register-actions'."
  3740. (let* ((val (get-text-property 0 'register register))
  3741. (desc (register-describe-oneline val))
  3742. (action (cdr (cl-assoc-if (lambda (re) (string-match-p re desc))
  3743. counsel-register-actions))))
  3744. (if action
  3745. (funcall action val)
  3746. (error "No action was found for register %s"
  3747. (single-key-description val)))))
  3748. ;;;###autoload
  3749. (defun counsel-register ()
  3750. "Interactively choose a register."
  3751. (interactive)
  3752. (ivy-read "Register: "
  3753. (cl-mapcan
  3754. (lambda (reg)
  3755. (let ((s (funcall register-preview-function reg)))
  3756. (setq s (substring s 0 (string-match-p "[ \t\n\r]+\\'" s)))
  3757. (unless (string= s "")
  3758. (put-text-property 0 1 'register (car reg) s)
  3759. (list s))))
  3760. register-alist)
  3761. :require-match t
  3762. :history 'counsel-register-history
  3763. :action #'counsel-register-action
  3764. :caller 'counsel-register))
  3765. (ivy-configure 'counsel-register
  3766. :sort-fn #'ivy-string<)
  3767. ;;** `counsel-evil-registers'
  3768. ;;;###autoload
  3769. (defun counsel-evil-registers ()
  3770. "Ivy replacement for `evil-show-registers'."
  3771. (interactive)
  3772. (if (fboundp 'evil-register-list)
  3773. (ivy-read "evil-registers: "
  3774. (cl-loop for (key . val) in (evil-register-list)
  3775. collect (format "[%c]: %s" key (if (stringp val) val "")))
  3776. :require-match t
  3777. :action #'counsel-evil-registers-action
  3778. :caller 'counsel-evil-registers)
  3779. (user-error "Required feature `evil' not installed.")))
  3780. (ivy-configure 'counsel-evil-registers
  3781. :height 5
  3782. :format-fn #'counsel--yank-pop-format-function)
  3783. (defun counsel-evil-registers-action (s)
  3784. "Paste contents of S, trimming the register part.
  3785. S will be of the form \"[register]: content\"."
  3786. (with-ivy-window
  3787. (insert
  3788. (replace-regexp-in-string "\\`\\[.*?\\]: " "" s))))
  3789. ;;** `counsel-imenu'
  3790. (defvar imenu-auto-rescan)
  3791. (defvar imenu-auto-rescan-maxout)
  3792. (declare-function imenu--subalist-p "imenu")
  3793. (declare-function imenu--make-index-alist "imenu")
  3794. (defun counsel--imenu-candidates ()
  3795. (unless (featurep 'imenu)
  3796. (require 'imenu nil t))
  3797. (let* ((imenu-auto-rescan t)
  3798. (imenu-auto-rescan-maxout (if current-prefix-arg
  3799. (buffer-size)
  3800. imenu-auto-rescan-maxout))
  3801. (items (imenu--make-index-alist t))
  3802. (items (delete (assoc "*Rescan*" items) items))
  3803. (items (counsel-imenu-categorize-functions items)))
  3804. (counsel-imenu-get-candidates-from items)))
  3805. (defun counsel-imenu-get-candidates-from (alist &optional prefix)
  3806. "Create a list of (key . value) from ALIST.
  3807. PREFIX is used to create the key."
  3808. (cl-mapcan
  3809. (lambda (elm)
  3810. (if (imenu--subalist-p elm)
  3811. (counsel-imenu-get-candidates-from
  3812. (cl-loop for (e . v) in (cdr elm) collect
  3813. (cons e (if (integerp v) (copy-marker v) v)))
  3814. ;; pass the prefix to next recursive call
  3815. (concat prefix (if prefix ".") (car elm)))
  3816. (let ((key (concat
  3817. (when prefix
  3818. (concat
  3819. (propertize prefix 'face 'ivy-grep-info)
  3820. ": "))
  3821. (car elm))))
  3822. (list (cons key
  3823. (cons key (if (overlayp (cdr elm))
  3824. (overlay-start (cdr elm))
  3825. (cdr elm))))))))
  3826. alist))
  3827. (defvar counsel-imenu-map
  3828. (let ((map (make-sparse-keymap)))
  3829. (define-key map (kbd "C-l") 'ivy-call-and-recenter)
  3830. map))
  3831. (defun counsel-imenu-categorize-functions (items)
  3832. "Categorize all the functions of imenu."
  3833. (let ((fns (cl-remove-if #'listp items :key #'cdr)))
  3834. (if fns
  3835. (nconc (cl-remove-if #'nlistp items :key #'cdr)
  3836. `(("Functions" ,@fns)))
  3837. items)))
  3838. (defun counsel-imenu-action (x)
  3839. (with-ivy-window
  3840. (imenu (cdr x))))
  3841. ;;;###autoload
  3842. (defun counsel-imenu ()
  3843. "Jump to a buffer position indexed by imenu."
  3844. (interactive)
  3845. (ivy-read "imenu items: " (counsel--imenu-candidates)
  3846. :preselect (thing-at-point 'symbol)
  3847. :require-match t
  3848. :action #'counsel-imenu-action
  3849. :keymap counsel-imenu-map
  3850. :caller 'counsel-imenu))
  3851. ;;** `counsel-list-processes'
  3852. (defun counsel-list-processes-action-delete (x)
  3853. "Delete process X."
  3854. (delete-process x)
  3855. (setf (ivy-state-collection ivy-last)
  3856. (setq ivy--all-candidates
  3857. (delete x ivy--all-candidates))))
  3858. (defun counsel-list-processes-action-switch (x)
  3859. "Switch to buffer of process X."
  3860. (let* ((proc (get-process x))
  3861. (buf (and proc (process-buffer proc))))
  3862. (if buf
  3863. (switch-to-buffer buf)
  3864. (message "Process %s doesn't have a buffer" x))))
  3865. ;;;###autoload
  3866. (defun counsel-list-processes ()
  3867. "Offer completion for `process-list'.
  3868. The default action deletes the selected process.
  3869. An extra action allows to switch to the process buffer."
  3870. (interactive)
  3871. (with-temp-buffer
  3872. (list-processes--refresh))
  3873. (ivy-read "Process: " (mapcar #'process-name (process-list))
  3874. :require-match t
  3875. :action
  3876. '(1
  3877. ("o" counsel-list-processes-action-delete "kill")
  3878. ("s" counsel-list-processes-action-switch "switch"))
  3879. :caller 'counsel-list-processes))
  3880. ;;** `counsel-ace-link'
  3881. (defun counsel-ace-link ()
  3882. "Use Ivy completion for `ace-link'."
  3883. (interactive)
  3884. (let (collection action)
  3885. (cond ((eq major-mode 'Info-mode)
  3886. (setq collection 'ace-link--info-collect)
  3887. (setq action 'ace-link--info-action))
  3888. ((eq major-mode 'help-mode)
  3889. (setq collection 'ace-link--help-collect)
  3890. (setq action 'ace-link--help-action))
  3891. ((eq major-mode 'woman-mode)
  3892. (setq collection 'ace-link--woman-collect)
  3893. (setq action 'ace-link--woman-action))
  3894. ((eq major-mode 'eww-mode)
  3895. (setq collection 'ace-link--eww-collect)
  3896. (setq action 'ace-link--eww-action))
  3897. ((eq major-mode 'compilation-mode)
  3898. (setq collection 'ace-link--eww-collect)
  3899. (setq action 'ace-link--compilation-action))
  3900. ((eq major-mode 'org-mode)
  3901. (setq collection 'ace-link--org-collect)
  3902. (setq action 'ace-link--org-action)))
  3903. (if (null collection)
  3904. (error "%S is not supported" major-mode)
  3905. (ivy-read "Ace-Link: " (funcall collection)
  3906. :action (lambda (x) (funcall action (cdr x)))
  3907. :require-match t
  3908. :caller 'counsel-ace-link))))
  3909. ;;** `counsel-minibuffer-history'
  3910. ;;;###autoload
  3911. (defun counsel-minibuffer-history ()
  3912. "Browse minibuffer history."
  3913. (interactive)
  3914. (let ((enable-recursive-minibuffers t))
  3915. (ivy-read "History: " (ivy-history-contents minibuffer-history-variable)
  3916. :keymap ivy-reverse-i-search-map
  3917. :action #'insert
  3918. :caller 'counsel-minibuffer-history)))
  3919. ;;** `counsel-esh-history'
  3920. (defun counsel--browse-history (ring)
  3921. "Use Ivy to navigate through RING."
  3922. (setq ivy-completion-beg (point))
  3923. (setq ivy-completion-end (point))
  3924. (ivy-read "History: " (ivy-history-contents ring)
  3925. :keymap ivy-reverse-i-search-map
  3926. :action #'ivy-completion-in-region-action
  3927. :caller 'counsel-shell-history))
  3928. (defvar eshell-history-ring)
  3929. ;;;###autoload
  3930. (defun counsel-esh-history ()
  3931. "Browse Eshell history."
  3932. (interactive)
  3933. (require 'em-hist)
  3934. (counsel--browse-history eshell-history-ring))
  3935. (defvar comint-input-ring)
  3936. ;;;###autoload
  3937. (defun counsel-shell-history ()
  3938. "Browse shell history."
  3939. (interactive)
  3940. (require 'comint)
  3941. (counsel--browse-history comint-input-ring))
  3942. (defvar slime-repl-input-history)
  3943. ;;;###autoload
  3944. (defun counsel-slime-repl-history ()
  3945. "Browse Slime REPL history."
  3946. (interactive)
  3947. (require 'slime-repl)
  3948. (counsel--browse-history slime-repl-input-history))
  3949. ;;** `counsel-hydra-heads'
  3950. (defvar hydra-curr-body-fn)
  3951. (declare-function hydra-keyboard-quit "ext:hydra")
  3952. ;;;###autoload
  3953. (defun counsel-hydra-heads ()
  3954. "Call a head of the current/last hydra."
  3955. (interactive)
  3956. (let* ((base (substring
  3957. (prin1-to-string hydra-curr-body-fn)
  3958. 0 -4))
  3959. (heads (eval (intern (concat base "heads"))))
  3960. (keymap (eval (intern (concat base "keymap"))))
  3961. (head-names
  3962. (mapcar (lambda (x)
  3963. (cons
  3964. (if (nth 2 x)
  3965. (format "[%s] %S (%s)" (nth 0 x) (nth 1 x) (nth 2 x))
  3966. (format "[%s] %S" (nth 0 x) (nth 1 x)))
  3967. (lookup-key keymap (kbd (nth 0 x)))))
  3968. heads)))
  3969. (ivy-read "head: " head-names
  3970. :action (lambda (x) (call-interactively (cdr x))))
  3971. (hydra-keyboard-quit)))
  3972. ;;** `counsel-semantic'
  3973. (declare-function semantic-tag-start "semantic/tag")
  3974. (declare-function semantic-tag-class "semantic/tag")
  3975. (declare-function semantic-tag-name "semantic/tag")
  3976. (declare-function semantic-tag-put-attribute "semantic/tag")
  3977. (declare-function semantic-tag-get-attribute "semantic/tag")
  3978. (declare-function semantic-fetch-tags "semantic")
  3979. (declare-function semantic-format-tag-summarize "semantic/format")
  3980. (declare-function semantic-active-p "semantic/fw")
  3981. (defun counsel-semantic-action (x)
  3982. "Got to semantic TAG."
  3983. (goto-char (semantic-tag-start (cdr x))))
  3984. (defvar counsel-semantic-history nil
  3985. "History for `counsel-semantic'.")
  3986. (defun counsel-semantic-format-tag (tag)
  3987. "Return a pretty string representation of TAG."
  3988. (let ((depth (or (semantic-tag-get-attribute tag :depth) 0))
  3989. (parent (semantic-tag-get-attribute tag :parent)))
  3990. (concat (make-string (* depth 2) ?\ )
  3991. (if parent
  3992. (concat "(" parent ") ")
  3993. "")
  3994. (semantic-format-tag-summarize tag nil t))))
  3995. (defun counsel-flatten-forest (func treep forest)
  3996. "Use FUNC and TREEP to flatten FOREST.
  3997. FUNC is applied to each node.
  3998. TREEP is used to expand internal nodes."
  3999. (cl-labels ((reducer (forest out depth)
  4000. (dolist (tree forest)
  4001. (let ((this (cons (funcall func tree depth) out))
  4002. (leafs (funcall treep tree)))
  4003. (setq out
  4004. (if leafs
  4005. (reducer leafs this (1+ depth))
  4006. this))))
  4007. out))
  4008. (nreverse (reducer forest nil 0))))
  4009. (defun counsel-semantic-tags ()
  4010. "Fetch semantic tags."
  4011. (counsel-flatten-forest
  4012. (lambda (tree depth)
  4013. (semantic-tag-put-attribute tree :depth depth))
  4014. (lambda (tag)
  4015. (when (eq (semantic-tag-class tag) 'type)
  4016. (let ((name (semantic-tag-name tag)))
  4017. (mapcar
  4018. (lambda (x) (semantic-tag-put-attribute x :parent name))
  4019. (semantic-tag-get-attribute tag :members)))))
  4020. (semantic-fetch-tags)))
  4021. ;;;###autoload
  4022. (defun counsel-semantic ()
  4023. "Jump to a semantic tag in the current buffer."
  4024. (interactive)
  4025. (let ((tags (mapcar
  4026. (lambda (x)
  4027. (cons
  4028. (counsel-semantic-format-tag x)
  4029. x))
  4030. (counsel-semantic-tags))))
  4031. (ivy-read "tag: " tags
  4032. :action #'counsel-semantic-action
  4033. :history 'counsel-semantic-history
  4034. :caller 'counsel-semantic)))
  4035. ;;;###autoload
  4036. (defun counsel-semantic-or-imenu ()
  4037. (interactive)
  4038. (require 'semantic/fw)
  4039. (if (semantic-active-p)
  4040. (counsel-semantic)
  4041. (counsel-imenu)))
  4042. ;;** `counsel-outline'
  4043. (defcustom counsel-outline-face-style nil
  4044. "Determines how to style outline headings during completion.
  4045. If `org', the faces `counsel-outline-1' through
  4046. `counsel-outline-8' are applied in a similar way to Org.
  4047. Note that no cycling is performed, so headings on levels 9 and
  4048. higher are not styled.
  4049. If `verbatim', the faces used in the buffer are applied. For
  4050. simple headlines in `org-mode' buffers, this is usually the same
  4051. as the `org' setting, except that it depends on how much of the
  4052. buffer has been completely fontified. If your buffer exceeds a
  4053. certain size, headlines are styled lazily depending on which
  4054. parts of the tree are visible. Headlines which are not yet
  4055. styled in the buffer will appear unstyled in the minibuffer as
  4056. well. If your headlines contain parts which are fontified
  4057. differently than the headline itself (e.g. TODO keywords, tags,
  4058. links) and you want these parts to be styled properly, verbatim
  4059. is the way to go; otherwise you are probably better off using the
  4060. `org' setting instead.
  4061. If `custom', the faces defined in `counsel-outline-custom-faces'
  4062. are applied. Note that no cycling is performed, so if there is
  4063. no face defined for a certain level, headlines on that level will
  4064. not be styled.
  4065. If `nil', all headlines are highlighted using
  4066. `counsel-outline-default'.
  4067. For displaying tags and TODO keywords in `org-mode' buffers, see
  4068. `counsel-org-headline-display-tags' and
  4069. `counsel-org-headline-display-todo', respectively."
  4070. :type '(choice
  4071. (const :tag "Same as org-mode" org)
  4072. (const :tag "Verbatim" verbatim)
  4073. (const :tag "Custom" custom)
  4074. (const :tag "No style" nil)))
  4075. (defcustom counsel-outline-custom-faces nil
  4076. "List of faces for custom display of outline headings.
  4077. Headlines on level N are fontified with the Nth entry of this
  4078. list, starting with N = 1. Headline levels with no corresponding
  4079. entry in this list will not be styled.
  4080. This variable has no effect unless `counsel-outline-face-style'
  4081. is set to `custom'."
  4082. :type '(repeat face))
  4083. (defun counsel-outline-title ()
  4084. "Return title of current outline heading.
  4085. Intended as a value for the `:outline-title' setting in
  4086. `counsel-outline-settings', which see."
  4087. (buffer-substring (point) (line-end-position)))
  4088. (defun counsel-outline-title-org ()
  4089. "Return title of current outline heading.
  4090. Like `counsel-outline-title' (which see), but for `org-mode'
  4091. buffers."
  4092. (apply #'org-get-heading (counsel--org-get-heading-args)))
  4093. (defun counsel-outline-title-markdown ()
  4094. "Return title of current outline heading.
  4095. Like `counsel-outline-title' (which see), but for
  4096. `markdown-mode' (from the eponymous package) buffers."
  4097. ;; `outline-regexp' is set by `markdown-mode' to match both setext
  4098. ;; (underline) and atx (hash) headings (see
  4099. ;; `markdown-regex-header').
  4100. (or (match-string 1) ; setext heading title
  4101. (match-string 5))) ; atx heading title
  4102. (defun counsel-outline-title-latex ()
  4103. "Return title of current outline heading.
  4104. Like `counsel-outline-title' (which see), but for `latex-mode'
  4105. buffers."
  4106. ;; `outline-regexp' is set by `latex-mode' (see variable
  4107. ;; `latex-section-alist' for the built-in mode or function
  4108. ;; `LaTeX-outline-regexp' for the AUCTeX package) to match section
  4109. ;; macros, in which case we get the section name, as well as
  4110. ;; `\appendix', `\documentclass', `\begin{document}', and
  4111. ;; `\end{document}', in which case we simply return that.
  4112. (if (and (assoc (match-string 1) ; Macro name
  4113. (or (bound-and-true-p LaTeX-section-list) ; AUCTeX
  4114. (bound-and-true-p latex-section-alist))) ; Built-in
  4115. (progn
  4116. ;; Point is at end of macro name, skip stars and optional args
  4117. (skip-chars-forward "*")
  4118. (while (looking-at-p "\\[")
  4119. (forward-list))
  4120. ;; First mandatory arg should be section title
  4121. (looking-at-p "{")))
  4122. (buffer-substring (1+ (point)) (1- (progn (forward-list) (point))))
  4123. (buffer-substring (line-beginning-position) (point))))
  4124. (defun counsel-outline-level-emacs-lisp ()
  4125. "Return level of current outline heading.
  4126. Like `lisp-outline-level', but adapted for the `:outline-level'
  4127. setting in `counsel-outline-settings', which see."
  4128. (if (looking-at ";;\\([;*]+\\)")
  4129. (- (match-end 1) (match-beginning 1))
  4130. (funcall outline-level)))
  4131. (defvar counsel-outline--preselect 0
  4132. "Index of the preselected candidate in `counsel-outline'.")
  4133. (defun counsel-outline-candidates (&optional settings prefix)
  4134. "Return an alist of outline heading completion candidates.
  4135. Each element is a pair (HEADING . MARKER), where the string
  4136. HEADING is located at the position of MARKER. SETTINGS is a
  4137. plist entry from `counsel-outline-settings', which see.
  4138. PREFIX is a string prepended to all candidates."
  4139. (let* ((bol-regex (concat "^\\(?:"
  4140. (or (plist-get settings :outline-regexp)
  4141. outline-regexp)
  4142. "\\)"))
  4143. (outline-title-fn (or (plist-get settings :outline-title)
  4144. #'counsel-outline-title))
  4145. (outline-level-fn (or (plist-get settings :outline-level)
  4146. outline-level))
  4147. (display-style (or (plist-get settings :display-style)
  4148. counsel-outline-display-style))
  4149. (path-separator (or (plist-get settings :path-separator)
  4150. counsel-outline-path-separator))
  4151. (face-style (or (plist-get settings :face-style)
  4152. counsel-outline-face-style))
  4153. (custom-faces (or (plist-get settings :custom-faces)
  4154. counsel-outline-custom-faces))
  4155. (stack-level 0)
  4156. (orig-point (point))
  4157. (stack (and prefix (list (counsel-outline--add-face
  4158. prefix 0 face-style custom-faces))))
  4159. cands name level marker)
  4160. (save-excursion
  4161. (setq counsel-outline--preselect 0)
  4162. (goto-char (point-min))
  4163. (while (re-search-forward bol-regex nil t)
  4164. (save-excursion
  4165. (setq name (or (save-match-data
  4166. (funcall outline-title-fn))
  4167. ""))
  4168. (goto-char (match-beginning 0))
  4169. (setq marker (point-marker))
  4170. (setq level (funcall outline-level-fn))
  4171. (cond ((eq display-style 'path)
  4172. ;; Update stack. The empty entry guards against incorrect
  4173. ;; headline hierarchies, e.g. a level 3 headline
  4174. ;; immediately following a level 1 entry.
  4175. (while (<= level stack-level)
  4176. (pop stack)
  4177. (cl-decf stack-level))
  4178. (while (> level stack-level)
  4179. (push "" stack)
  4180. (cl-incf stack-level))
  4181. (setf (car stack)
  4182. (counsel-outline--add-face
  4183. name level face-style custom-faces))
  4184. (setq name (mapconcat #'identity
  4185. (reverse stack)
  4186. path-separator)))
  4187. (t
  4188. (when (eq display-style 'headline)
  4189. (setq name (concat (make-string level ?*) " " name)))
  4190. (setq name (counsel-outline--add-face
  4191. name level face-style custom-faces))))
  4192. (push (cons name marker) cands))
  4193. (unless (or (string= name "")
  4194. (< orig-point marker))
  4195. (cl-incf counsel-outline--preselect))))
  4196. (nreverse cands)))
  4197. (defun counsel-outline--add-face (name level &optional face-style custom-faces)
  4198. "Set the `face' property on headline NAME according to LEVEL.
  4199. FACE-STYLE and CUSTOM-FACES override `counsel-outline-face-style'
  4200. and `counsel-outline-custom-faces', respectively, which determine
  4201. the face to apply."
  4202. (let ((face (cl-case (or face-style counsel-outline-face-style)
  4203. (verbatim)
  4204. (custom (nth (1- level)
  4205. (or custom-faces counsel-outline-custom-faces)))
  4206. (org (format "counsel-outline-%d" level))
  4207. (t 'counsel-outline-default))))
  4208. (when face
  4209. (put-text-property 0 (length name) 'face face name)))
  4210. name)
  4211. (defun counsel-outline-action (x)
  4212. "Go to outline X."
  4213. (goto-char (cdr x)))
  4214. ;;;###autoload
  4215. (defun counsel-outline ()
  4216. "Jump to an outline heading with completion."
  4217. (interactive)
  4218. (let ((settings (cdr (assq major-mode counsel-outline-settings))))
  4219. (ivy-read "Outline: " (counsel-outline-candidates settings)
  4220. :action (or (plist-get settings :action)
  4221. #'counsel-outline-action)
  4222. :history (or (plist-get settings :history)
  4223. 'counsel-outline-history)
  4224. :preselect (max (1- counsel-outline--preselect) 0)
  4225. :caller (or (plist-get settings :caller)
  4226. 'counsel-outline))))
  4227. ;;** `counsel-ibuffer'
  4228. (defvar counsel-ibuffer--buffer-name nil
  4229. "Name of the buffer to use for `counsel-ibuffer'.")
  4230. ;;;###autoload
  4231. (defun counsel-ibuffer (&optional name)
  4232. "Use ibuffer to switch to another buffer.
  4233. NAME specifies the name of the buffer (defaults to \"*Ibuffer*\")."
  4234. (interactive)
  4235. (setq counsel-ibuffer--buffer-name (or name "*Ibuffer*"))
  4236. (ivy-read "Switch to buffer: " (counsel-ibuffer--get-buffers)
  4237. :history 'counsel-ibuffer-history
  4238. :action #'counsel-ibuffer-visit-buffer
  4239. :caller 'counsel-ibuffer))
  4240. (declare-function ibuffer-update "ibuffer")
  4241. (declare-function ibuffer-current-buffer "ibuffer")
  4242. (declare-function ibuffer-forward-line "ibuffer")
  4243. (defvar ibuffer-movement-cycle)
  4244. (defun counsel-ibuffer--get-buffers ()
  4245. "Return list of buffer-related lines in Ibuffer as strings."
  4246. (let ((oldbuf (get-buffer counsel-ibuffer--buffer-name)))
  4247. (unless oldbuf
  4248. ;; Avoid messing with the user's precious window/frame configuration.
  4249. (save-window-excursion
  4250. (let ((display-buffer-overriding-action
  4251. '(display-buffer-same-window (inhibit-same-window . nil))))
  4252. (ibuffer nil counsel-ibuffer--buffer-name nil t))))
  4253. (with-current-buffer counsel-ibuffer--buffer-name
  4254. (when oldbuf
  4255. ;; Forcibly update possibly stale existing buffer.
  4256. (ibuffer-update nil t))
  4257. (goto-char (point-min))
  4258. (let ((ibuffer-movement-cycle nil)
  4259. entries)
  4260. (while (not (eobp))
  4261. (ibuffer-forward-line 1 t)
  4262. (let ((buf (ibuffer-current-buffer)))
  4263. ;; We are only interested in buffers we can actually visit.
  4264. ;; This filters out headings and other unusable entries.
  4265. (when (buffer-live-p buf)
  4266. (push (cons (buffer-substring-no-properties
  4267. (line-beginning-position)
  4268. (line-end-position))
  4269. buf)
  4270. entries))))
  4271. (nreverse entries)))))
  4272. (defun counsel-ibuffer-visit-buffer (x)
  4273. "Switch to buffer of candidate X."
  4274. (switch-to-buffer (cdr x)))
  4275. (defun counsel-ibuffer-visit-buffer-other-window (x)
  4276. "Switch to buffer of candidate X in another window."
  4277. (switch-to-buffer-other-window (cdr x)))
  4278. (defun counsel-ibuffer-visit-ibuffer (_)
  4279. "Switch to Ibuffer buffer."
  4280. (switch-to-buffer counsel-ibuffer--buffer-name))
  4281. (ivy-set-actions
  4282. 'counsel-ibuffer
  4283. '(("j" counsel-ibuffer-visit-buffer-other-window "other window")
  4284. ("v" counsel-ibuffer-visit-ibuffer "switch to Ibuffer")))
  4285. ;;** `counsel-switch-to-shell-buffer'
  4286. (defun counsel--buffers-with-mode (mode)
  4287. "Return names of buffers with MODE as their `major-mode'."
  4288. (let (bufs)
  4289. (dolist (buf (buffer-list))
  4290. (when (eq (buffer-local-value 'major-mode buf) mode)
  4291. (push (buffer-name buf) bufs)))
  4292. (nreverse bufs)))
  4293. (declare-function shell-mode "shell")
  4294. ;;;###autoload
  4295. (defun counsel-switch-to-shell-buffer ()
  4296. "Switch to a shell buffer, or create one."
  4297. (interactive)
  4298. (ivy-read "Shell buffer: " (counsel--buffers-with-mode #'shell-mode)
  4299. :action #'counsel--switch-to-shell
  4300. :caller 'counsel-switch-to-shell-buffer))
  4301. (defun counsel--switch-to-shell (name)
  4302. "Display shell buffer with NAME and select its window.
  4303. Reuse any existing window already displaying the named buffer.
  4304. If there is no such buffer, start a new `shell' with NAME."
  4305. (if (get-buffer name)
  4306. (pop-to-buffer name '((display-buffer-reuse-window
  4307. display-buffer-same-window)
  4308. (inhibit-same-window . nil)
  4309. (reusable-frames . visible)))
  4310. (shell name)))
  4311. ;;** `counsel-unicode-char'
  4312. (defvar counsel-unicode-char-history nil
  4313. "History for `counsel-unicode-char'.")
  4314. (defun counsel--unicode-names ()
  4315. "Return formatted and sorted list of `ucs-names'.
  4316. The result of `ucs-names' is mostly, but not completely, sorted,
  4317. so this function ensures lexicographic order."
  4318. (let* (cands
  4319. (table (ucs-names)) ; Either hash map or alist
  4320. (fmt (lambda (name code) ; Common format function
  4321. (let ((cand (format "%06X %-58s %c" code name code)))
  4322. (put-text-property 0 1 'code code cand)
  4323. (push cand cands)))))
  4324. (if (not (hash-table-p table))
  4325. ;; Support `ucs-names' returning an alist in Emacs < 26.
  4326. ;; The result of `ucs-names' comes pre-reversed so no need to repeat.
  4327. (dolist (entry table)
  4328. (funcall fmt (car entry) (cdr entry)))
  4329. (maphash fmt table)
  4330. ;; Reverse to speed up sorting
  4331. (setq cands (nreverse cands)))
  4332. (sort cands #'string-lessp)))
  4333. (defvar counsel--unicode-table
  4334. (lazy-completion-table counsel--unicode-table counsel--unicode-names)
  4335. "Lazy completion table for `counsel-unicode-char'.
  4336. Candidates comprise `counsel--unicode-names', which see.")
  4337. ;;;###autoload
  4338. (defun counsel-unicode-char (&optional count)
  4339. "Insert COUNT copies of a Unicode character at point.
  4340. COUNT defaults to 1."
  4341. (interactive "p")
  4342. (setq ivy-completion-beg (point))
  4343. (setq ivy-completion-end (point))
  4344. (ivy-read "Unicode name: " counsel--unicode-table
  4345. :history 'counsel-unicode-char-history
  4346. :action (lambda (name)
  4347. (with-ivy-window
  4348. (delete-region ivy-completion-beg ivy-completion-end)
  4349. (setq ivy-completion-beg (point))
  4350. (insert-char (get-text-property 0 'code name) count)
  4351. (setq ivy-completion-end (point))))
  4352. :caller 'counsel-unicode-char))
  4353. (ivy-configure 'counsel-unicode-char
  4354. :sort-fn #'ivy-string<)
  4355. (defun counsel-unicode-copy (name)
  4356. "Ivy action to copy the unicode from NAME to the kill ring."
  4357. (kill-new (char-to-string (get-text-property 0 'code name))))
  4358. (ivy-set-actions
  4359. 'counsel-unicode-char
  4360. '(("w" counsel-unicode-copy "copy")))
  4361. ;;** `counsel-colors'
  4362. (defun counsel-colors-action-insert-hex (color)
  4363. "Insert the hexadecimal RGB value of COLOR."
  4364. (insert (get-text-property 0 'hex color)))
  4365. (defun counsel-colors-action-kill-hex (color)
  4366. "Kill the hexadecimal RGB value of COLOR."
  4367. (kill-new (get-text-property 0 'hex color)))
  4368. ;;** `counsel-colors-emacs'
  4369. (defvar counsel-colors-emacs-history ()
  4370. "History for `counsel-colors-emacs'.")
  4371. (defun counsel-colors--name-to-hex (name)
  4372. "Return hexadecimal RGB value of color with NAME.
  4373. Return nil if NAME does not designate a valid color."
  4374. (let ((rgb (color-name-to-rgb name)))
  4375. (when rgb
  4376. (apply #'color-rgb-to-hex rgb))))
  4377. (defvar shr-color-visible-luminance-min)
  4378. (declare-function shr-color-visible "shr-color")
  4379. (defvar counsel--colors-format "%-20s %s %s%s")
  4380. (defun counsel--colors-emacs-format-function (colors)
  4381. "Format function for `counsel-colors-emacs'."
  4382. (require 'shr-color)
  4383. (let* ((blank (make-string 10 ?\s))
  4384. (formatter
  4385. (lambda (color)
  4386. (let ((fg (list :foreground color)))
  4387. (format counsel--colors-format color
  4388. (propertize (get-text-property 0 'hex color) 'face fg)
  4389. (propertize blank 'face (list :background color))
  4390. (propertize (mapconcat (lambda (dup)
  4391. (concat " " dup))
  4392. (get-text-property 0 'dups color)
  4393. ",")
  4394. 'face fg))))))
  4395. (ivy--format-function-generic
  4396. (lambda (color)
  4397. (let* ((hex (get-text-property 0 'hex color))
  4398. (shr-color-visible-luminance-min 100)
  4399. (fg (cadr (shr-color-visible hex "black" t))))
  4400. (propertize (funcall formatter color)
  4401. 'face (list :foreground fg :background hex))))
  4402. formatter colors "\n")))
  4403. (defun counsel--colors-web-format-function (colors)
  4404. "Format function for `counsel-colors-web'."
  4405. (require 'shr-color)
  4406. (let* ((blank (make-string 10 ?\s))
  4407. (formatter (lambda (color)
  4408. (let ((hex (get-text-property 0 'hex color)))
  4409. (format counsel--colors-format color
  4410. (propertize hex 'face (list :foreground hex))
  4411. (propertize blank 'face (list :background hex)))))))
  4412. (ivy--format-function-generic
  4413. (lambda (color)
  4414. (let* ((hex (get-text-property 0 'hex color))
  4415. (shr-color-visible-luminance-min 100)
  4416. (fg (cadr (shr-color-visible hex "black" t))))
  4417. (propertize (funcall formatter color)
  4418. 'face (list :foreground fg :background hex))))
  4419. formatter colors "\n")))
  4420. ;;;###autoload
  4421. (defun counsel-colors-emacs ()
  4422. "Show a list of all supported colors for a particular frame.
  4423. You can insert or kill the name or hexadecimal RGB value of the
  4424. selected color."
  4425. (interactive)
  4426. (let* ((colors
  4427. (delete nil
  4428. (mapcar (lambda (cell)
  4429. (let* ((name (car cell))
  4430. (dups (cdr cell))
  4431. (hex (counsel-colors--name-to-hex name)))
  4432. (when hex
  4433. (propertize name 'hex hex 'dups dups))))
  4434. (list-colors-duplicates))))
  4435. (counsel--colors-format
  4436. (format "%%-%ds %%s %%s%%s"
  4437. (apply #'max 0 (mapcar #'string-width colors)))))
  4438. (ivy-read "Emacs color: " colors
  4439. :require-match t
  4440. :history 'counsel-colors-emacs-history
  4441. :action #'insert
  4442. :caller 'counsel-colors-emacs)))
  4443. (ivy-configure 'counsel-colors-emacs
  4444. :format-fn #'counsel--colors-emacs-format-function)
  4445. (ivy-set-actions
  4446. 'counsel-colors-emacs
  4447. '(("h" counsel-colors-action-insert-hex "insert hexadecimal value")
  4448. ("H" counsel-colors-action-kill-hex "kill hexadecimal value")))
  4449. ;;** `counsel-colors-web'
  4450. (defvar shr-color-html-colors-alist)
  4451. (defun counsel-colors--web-alist ()
  4452. "Return list of CSS colors for `counsel-colors-web'."
  4453. (require 'shr-color)
  4454. (let* ((alist (copy-alist shr-color-html-colors-alist))
  4455. (mp (assoc "MediumPurple" alist))
  4456. (pvr (assoc "PaleVioletRed" alist))
  4457. (rp (assoc "RebeccaPurple" alist)))
  4458. ;; Backport GNU Emacs bug#30377
  4459. (when mp (setcdr mp "#9370db"))
  4460. (when pvr (setcdr pvr "#db7093"))
  4461. (unless rp (push (cons "rebeccapurple" "#663399") alist))
  4462. (sort (mapcar (lambda (cell)
  4463. (propertize (downcase (car cell))
  4464. 'hex (downcase (cdr cell))))
  4465. alist)
  4466. #'string-lessp)))
  4467. (defvar counsel-colors-web-history ()
  4468. "History for `counsel-colors-web'.")
  4469. ;;;###autoload
  4470. (defun counsel-colors-web ()
  4471. "Show a list of all W3C web colors for use in CSS.
  4472. You can insert or kill the name or hexadecimal RGB value of the
  4473. selected color."
  4474. (interactive)
  4475. (let* ((colors (counsel-colors--web-alist))
  4476. (counsel--colors-format
  4477. (format "%%-%ds %%s %%s"
  4478. (apply #'max 0 (mapcar #'string-width colors)))))
  4479. (ivy-read "Web color: " colors
  4480. :require-match t
  4481. :history 'counsel-colors-web-history
  4482. :action #'insert
  4483. :caller 'counsel-colors-web)))
  4484. (ivy-configure 'counsel-colors-web
  4485. :sort-fn #'ivy-string<
  4486. :format-fn #'counsel--colors-web-format-function)
  4487. (ivy-set-actions
  4488. 'counsel-colors-web
  4489. '(("h" counsel-colors-action-insert-hex "insert hexadecimal value")
  4490. ("H" counsel-colors-action-kill-hex "kill hexadecimal value")))
  4491. ;;** `counsel-fonts'
  4492. (defvar counsel-fonts-history ()
  4493. "History for `counsel-fonts'.")
  4494. ;;;###autoload
  4495. (defun counsel-fonts ()
  4496. "Show a list of all supported font families for a particular frame.
  4497. You can insert or kill the name of the selected font."
  4498. (interactive)
  4499. (ivy-read "Font: " (delete-dups (font-family-list))
  4500. :require-match t
  4501. :history 'counsel-fonts-history
  4502. :action #'insert
  4503. :caller 'counsel-fonts))
  4504. ;;* Misc. OS
  4505. ;;** `counsel-rhythmbox'
  4506. (declare-function dbus-call-method "dbus")
  4507. (declare-function dbus-get-property "dbus")
  4508. (defun counsel--run (&rest program-and-args)
  4509. (let ((name (mapconcat #'identity program-and-args " ")))
  4510. (apply #'start-process name nil program-and-args)
  4511. name))
  4512. (defun counsel--sl (cmd)
  4513. "Shell command to list."
  4514. (split-string (shell-command-to-string cmd) "\n" t))
  4515. (defun counsel-rhythmbox-play-song (song)
  4516. "Let Rhythmbox play SONG."
  4517. (let ((first (string= (shell-command-to-string "pidof rhythmbox") ""))
  4518. (service "org.gnome.Rhythmbox3")
  4519. (path "/org/mpris/MediaPlayer2")
  4520. (interface "org.mpris.MediaPlayer2.Player"))
  4521. (when first
  4522. (counsel--run "nohup" "rhythmbox")
  4523. (sit-for 1.5))
  4524. (dbus-call-method :session service path interface
  4525. "OpenUri" (cdr song))
  4526. (let ((id (and first
  4527. (cdr (counsel--wmctrl-parse
  4528. (shell-command-to-string
  4529. "wmctrl -l -p | grep $(pidof rhythmbox)"))))))
  4530. (when id
  4531. (sit-for 0.2)
  4532. (counsel--run "wmctrl" "-ic" id)))))
  4533. (defun counsel-rhythmbox-enqueue-song (song)
  4534. "Let Rhythmbox enqueue SONG."
  4535. (let ((service "org.gnome.Rhythmbox3")
  4536. (path "/org/gnome/Rhythmbox3/PlayQueue")
  4537. (interface "org.gnome.Rhythmbox3.PlayQueue"))
  4538. (dbus-call-method :session service path interface
  4539. "AddToQueue" (cdr song))))
  4540. (defun counsel-rhythmbox-toggle-shuffle (_song)
  4541. "Toggle Rhythmbox shuffle setting."
  4542. (let* ((old-order (counsel--command "dconf" "read" "/org/gnome/rhythmbox/player/play-order"))
  4543. (new-order (if (string= old-order "'shuffle'")
  4544. "'linear'"
  4545. "'shuffle'")))
  4546. (counsel--command
  4547. "dconf"
  4548. "write"
  4549. "/org/gnome/rhythmbox/player/play-order"
  4550. new-order)
  4551. (message (if (string= new-order "'shuffle'")
  4552. "shuffle on"
  4553. "shuffle off"))))
  4554. (defvar counsel-rhythmbox-history nil
  4555. "History for `counsel-rhythmbox'.")
  4556. (defvar counsel-rhythmbox-songs nil)
  4557. (defun counsel-rhythmbox-current-song ()
  4558. "Return the currently playing song title."
  4559. (ignore-errors
  4560. (let* ((entry (dbus-get-property
  4561. :session
  4562. "org.mpris.MediaPlayer2.rhythmbox"
  4563. "/org/mpris/MediaPlayer2"
  4564. "org.mpris.MediaPlayer2.Player"
  4565. "Metadata"))
  4566. (artist (caar (cadr (assoc "xesam:artist" entry))))
  4567. (album (cl-caadr (assoc "xesam:album" entry)))
  4568. (title (cl-caadr (assoc "xesam:title" entry))))
  4569. (format "%s - %s - %s" artist album title))))
  4570. ;;;###autoload
  4571. (defun counsel-rhythmbox (&optional arg)
  4572. "Choose a song from the Rhythmbox library to play or enqueue."
  4573. (interactive "P")
  4574. (require 'dbus)
  4575. (when (or arg (null counsel-rhythmbox-songs))
  4576. (let* ((service "org.gnome.Rhythmbox3")
  4577. (path "/org/gnome/UPnP/MediaServer2/Library/all")
  4578. (interface "org.gnome.UPnP.MediaContainer2")
  4579. (nb-songs (dbus-get-property
  4580. :session service path interface "ChildCount")))
  4581. (if (not nb-songs)
  4582. (error "Couldn't connect to Rhythmbox")
  4583. (setq counsel-rhythmbox-songs
  4584. (mapcar (lambda (x)
  4585. (cons
  4586. (format
  4587. "%s - %s - %s"
  4588. (cl-caadr (assoc "Artist" x))
  4589. (cl-caadr (assoc "Album" x))
  4590. (cl-caadr (assoc "DisplayName" x)))
  4591. (cl-caaadr (assoc "URLs" x))))
  4592. (dbus-call-method
  4593. :session service path interface "ListChildren"
  4594. 0 nb-songs '("*")))))))
  4595. (ivy-read "Rhythmbox: " counsel-rhythmbox-songs
  4596. :require-match t
  4597. :history 'counsel-rhythmbox-history
  4598. :preselect (counsel-rhythmbox-current-song)
  4599. :action
  4600. '(1
  4601. ("p" counsel-rhythmbox-play-song "Play song")
  4602. ("e" counsel-rhythmbox-enqueue-song "Enqueue song")
  4603. ("s" counsel-rhythmbox-toggle-shuffle "Shuffle on/off"))
  4604. :caller 'counsel-rhythmbox))
  4605. ;;** `counsel-linux-app'
  4606. (require 'xdg nil t)
  4607. (defalias 'counsel--xdg-data-home
  4608. (if (fboundp 'xdg-data-home)
  4609. #'xdg-data-home
  4610. (lambda ()
  4611. (let ((directory (getenv "XDG_DATA_HOME")))
  4612. (if (or (null directory) (string= directory ""))
  4613. "~/.local/share"
  4614. directory))))
  4615. "Compatibility shim for `xdg-data-home'.")
  4616. (defalias 'counsel--xdg-data-dirs
  4617. (if (fboundp 'xdg-data-dirs)
  4618. #'xdg-data-dirs
  4619. (lambda ()
  4620. (let ((path (getenv "XDG_DATA_DIRS")))
  4621. (if (or (null path) (string= path ""))
  4622. '("/usr/local/share" "/usr/share")
  4623. (parse-colon-path path)))))
  4624. "Compatibility shim for `xdg-data-dirs'.")
  4625. (defcustom counsel-linux-apps-directories
  4626. (mapcar (lambda (dir) (expand-file-name "applications" dir))
  4627. (cons (counsel--xdg-data-home)
  4628. (counsel--xdg-data-dirs)))
  4629. "Directories in which to search for applications (.desktop files)."
  4630. :type '(repeat directory))
  4631. (defcustom counsel-linux-app-format-function #'counsel-linux-app-format-function-default
  4632. "Function to format Linux application names the `counsel-linux-app' menu.
  4633. The format function will be passed the application's name, comment, and command
  4634. as arguments."
  4635. :type '(choice
  4636. (const :tag "Command : Name - Comment" counsel-linux-app-format-function-default)
  4637. (const :tag "Name - Comment (Command)" counsel-linux-app-format-function-name-first)
  4638. (const :tag "Name - Comment" counsel-linux-app-format-function-name-only)
  4639. (const :tag "Command" counsel-linux-app-format-function-command-only)
  4640. (function :tag "Custom")))
  4641. (defface counsel-application-name
  4642. '((t :inherit font-lock-builtin-face))
  4643. "Face for displaying executable names."
  4644. :group 'ivy-faces)
  4645. (defface counsel-outline-1
  4646. '((t :inherit org-level-1))
  4647. "Face for displaying level 1 headings."
  4648. :group 'ivy-faces)
  4649. (defface counsel-outline-2
  4650. '((t :inherit org-level-2))
  4651. "Face for displaying level 2 headings."
  4652. :group 'ivy-faces)
  4653. (defface counsel-outline-3
  4654. '((t :inherit org-level-3))
  4655. "Face for displaying level 3 headings."
  4656. :group 'ivy-faces)
  4657. (defface counsel-outline-4
  4658. '((t :inherit org-level-4))
  4659. "Face for displaying level 4 headings."
  4660. :group 'ivy-faces)
  4661. (defface counsel-outline-5
  4662. '((t :inherit org-level-5))
  4663. "Face for displaying level 5 headings."
  4664. :group 'ivy-faces)
  4665. (defface counsel-outline-6
  4666. '((t :inherit org-level-6))
  4667. "Face for displaying level 6 headings."
  4668. :group 'ivy-faces)
  4669. (defface counsel-outline-7
  4670. '((t :inherit org-level-7))
  4671. "Face for displaying level 7 headings."
  4672. :group 'ivy-faces)
  4673. (defface counsel-outline-8
  4674. '((t :inherit org-level-8))
  4675. "Face for displaying level 8 headings."
  4676. :group 'ivy-faces)
  4677. (defface counsel-outline-default
  4678. '((t :inherit minibuffer-prompt))
  4679. "Face for displaying headings."
  4680. :group 'ivy-faces)
  4681. (defvar counsel-linux-apps-faulty nil
  4682. "List of faulty desktop files.")
  4683. (defvar counsel--linux-apps-cache nil
  4684. "Cache of desktop files data.")
  4685. (defvar counsel--linux-apps-cached-files nil
  4686. "List of cached desktop files.")
  4687. (defvar counsel--linux-apps-cache-timestamp nil
  4688. "Time when we last updated the cached application list.")
  4689. (defvar counsel--linux-apps-cache-format-function nil
  4690. "The function used to format the cached Linux application menu.")
  4691. (defun counsel-linux-app-format-function-default (name comment exec)
  4692. "Default Linux application name formatter.
  4693. NAME is the name of the application, COMMENT its comment and EXEC
  4694. the command to launch it."
  4695. (format "% -45s: %s%s"
  4696. (propertize
  4697. (ivy--truncate-string exec 45)
  4698. 'face 'counsel-application-name)
  4699. name
  4700. (if comment
  4701. (concat " - " comment)
  4702. "")))
  4703. (defun counsel-linux-app-format-function-name-first (name comment exec)
  4704. "Format Linux application names with the NAME (and COMMENT) first.
  4705. EXEC is the command to launch the application."
  4706. (format "%s%s (%s)"
  4707. name
  4708. (if comment
  4709. (concat " - " comment)
  4710. "")
  4711. (propertize exec 'face 'counsel-application-name)))
  4712. (defun counsel-linux-app-format-function-name-only (name comment _exec)
  4713. "Format Linux application names with the NAME (and COMMENT) only."
  4714. (format "%s%s"
  4715. name
  4716. (if comment
  4717. (concat " - " comment)
  4718. "")))
  4719. (defun counsel-linux-app-format-function-command-only (_name _comment exec)
  4720. "Display only the command EXEC when formatting Linux application names."
  4721. exec)
  4722. (defun counsel-linux-apps-list-desktop-files ()
  4723. "Return an alist of all Linux applications.
  4724. Each list entry is a pair of (desktop-name . desktop-file).
  4725. This function always returns its elements in a stable order."
  4726. (let ((hash (make-hash-table :test #'equal))
  4727. result)
  4728. (dolist (dir counsel-linux-apps-directories)
  4729. (when (file-exists-p dir)
  4730. (let ((dir (file-name-as-directory dir)))
  4731. (dolist (file (directory-files-recursively dir ".*\\.desktop$"))
  4732. (let ((id (subst-char-in-string ?/ ?- (file-relative-name file dir))))
  4733. (when (and (not (gethash id hash)) (file-readable-p file))
  4734. (push (cons id file) result)
  4735. (puthash id file hash)))))))
  4736. result))
  4737. (defun counsel-linux-app--parse-file (file)
  4738. (with-temp-buffer
  4739. (insert-file-contents file)
  4740. (goto-char (point-min))
  4741. (let ((start (re-search-forward "^\\[Desktop Entry\\] *$" nil t))
  4742. (end (re-search-forward "^\\[" nil t))
  4743. (visible t)
  4744. name comment exec)
  4745. (catch 'break
  4746. (unless start
  4747. (push file counsel-linux-apps-faulty)
  4748. (message "Warning: File %s has no [Desktop Entry] group" file)
  4749. (throw 'break nil))
  4750. (goto-char start)
  4751. (when (re-search-forward "^\\(Hidden\\|NoDisplay\\) *= *\\(1\\|true\\) *$" end t)
  4752. (setq visible nil))
  4753. (setq name (match-string 1))
  4754. (goto-char start)
  4755. (unless (re-search-forward "^Type *= *Application *$" end t)
  4756. (throw 'break nil))
  4757. (setq name (match-string 1))
  4758. (goto-char start)
  4759. (unless (re-search-forward "^Name *= *\\(.+\\)$" end t)
  4760. (push file counsel-linux-apps-faulty)
  4761. (message "Warning: File %s has no Name" file)
  4762. (throw 'break nil))
  4763. (setq name (match-string 1))
  4764. (goto-char start)
  4765. (when (re-search-forward "^Comment *= *\\(.+\\)$" end t)
  4766. (setq comment (match-string 1)))
  4767. (goto-char start)
  4768. (unless (re-search-forward "^Exec *= *\\(.+\\)$" end t)
  4769. ;; Don't warn because this can technically be a valid desktop file.
  4770. (throw 'break nil))
  4771. (setq exec (match-string 1))
  4772. (goto-char start)
  4773. (when (re-search-forward "^TryExec *= *\\(.+\\)$" end t)
  4774. (let ((try-exec (match-string 1)))
  4775. (unless (locate-file try-exec exec-path nil #'file-executable-p)
  4776. (throw 'break nil))))
  4777. (propertize
  4778. (funcall counsel-linux-app-format-function name comment exec)
  4779. 'visible visible)))))
  4780. (defun counsel-linux-apps-parse (desktop-entries-alist)
  4781. "Parse the given alist of Linux desktop entries.
  4782. Each entry in DESKTOP-ENTRIES-ALIST is a pair of ((id . file-name)).
  4783. Any desktop entries that fail to parse are recorded in
  4784. `counsel-linux-apps-faulty'."
  4785. (let (result)
  4786. (setq counsel-linux-apps-faulty nil)
  4787. (dolist (entry desktop-entries-alist result)
  4788. (let* ((id (car entry))
  4789. (file (cdr entry))
  4790. (r (counsel-linux-app--parse-file file)))
  4791. (when r
  4792. (push (cons r id) result))))))
  4793. (defun counsel-linux-apps-list ()
  4794. "Return list of all Linux desktop applications."
  4795. (let* ((new-desktop-alist (counsel-linux-apps-list-desktop-files))
  4796. (new-files (mapcar 'cdr new-desktop-alist)))
  4797. (unless (and
  4798. (eq counsel-linux-app-format-function
  4799. counsel--linux-apps-cache-format-function)
  4800. (equal new-files counsel--linux-apps-cached-files)
  4801. (null (cl-find-if
  4802. (lambda (file)
  4803. (time-less-p
  4804. counsel--linux-apps-cache-timestamp
  4805. (nth 5 (file-attributes file))))
  4806. new-files)))
  4807. (setq counsel--linux-apps-cache (counsel-linux-apps-parse new-desktop-alist))
  4808. (setq counsel--linux-apps-cache-format-function counsel-linux-app-format-function)
  4809. (setq counsel--linux-apps-cache-timestamp (current-time))
  4810. (setq counsel--linux-apps-cached-files new-files)))
  4811. counsel--linux-apps-cache)
  4812. (defun counsel-linux-app-action-default (desktop-shortcut)
  4813. "Launch DESKTOP-SHORTCUT."
  4814. (call-process "gtk-launch" nil 0 nil (cdr desktop-shortcut)))
  4815. (defun counsel-linux-app-action-file (desktop-shortcut)
  4816. "Launch DESKTOP-SHORTCUT with a selected file."
  4817. (call-process "gtk-launch" nil 0 nil
  4818. (cdr desktop-shortcut)
  4819. (read-file-name "File: ")))
  4820. (defun counsel-linux-app-action-open-desktop (desktop-shortcut)
  4821. "Open DESKTOP-SHORTCUT."
  4822. (let* ((app (cdr desktop-shortcut))
  4823. (file (cdr (assoc app (counsel-linux-apps-list-desktop-files)))))
  4824. (if file
  4825. (find-file file)
  4826. (error "Could not find location of file %s" app))))
  4827. (ivy-set-actions
  4828. 'counsel-linux-app
  4829. '(("f" counsel-linux-app-action-file "run on a file")
  4830. ("d" counsel-linux-app-action-open-desktop "open desktop file")))
  4831. ;;;###autoload
  4832. (defun counsel-linux-app (&optional arg)
  4833. "Launch a Linux desktop application, similar to Alt-<F2>.
  4834. When ARG is non-nil, ignore NoDisplay property in *.desktop files."
  4835. (interactive "P")
  4836. (ivy-read "Run a command: " (counsel-linux-apps-list)
  4837. :predicate (unless arg (lambda (x) (get-text-property 0 'visible (car x))))
  4838. :action #'counsel-linux-app-action-default
  4839. :caller 'counsel-linux-app))
  4840. ;;** `counsel-wmctrl'
  4841. (defun counsel-wmctrl-action (x)
  4842. "Select the desktop window that corresponds to X."
  4843. (counsel--run "wmctrl" "-i" "-a" (cdr x)))
  4844. (defvar counsel-wmctrl-ignore '("XdndCollectionWindowImp"
  4845. "unity-launcher" "unity-panel" "unity-dash"
  4846. "Hud" "Desktop")
  4847. "List of window titles to ignore for `counsel-wmctrl'.")
  4848. (defun counsel--wmctrl-parse (s)
  4849. (when (string-match "\\`\\([0-9a-fx]+\\) +\\([-0-9]+\\) +\\(?:[0-9]+\\) +\\([^ ]+\\) \\(.+\\)$" s)
  4850. (let ((title (match-string 4 s))
  4851. (id (match-string 1 s)))
  4852. (unless (member title counsel-wmctrl-ignore)
  4853. (cons title id)))))
  4854. ;;;###autoload
  4855. (defun counsel-wmctrl ()
  4856. "Select a desktop window using wmctrl."
  4857. (interactive)
  4858. (let* ((cands1 (counsel--sl "wmctrl -l -p"))
  4859. (cands2 (delq nil (mapcar #'counsel--wmctrl-parse cands1))))
  4860. (ivy-read "window: " cands2
  4861. :action #'counsel-wmctrl-action
  4862. :caller 'counsel-wmctrl)))
  4863. (defvar counsel--switch-buffer-temporary-buffers nil
  4864. "Internal.")
  4865. (defvar counsel--switch-buffer-previous-buffers nil
  4866. "Internal.")
  4867. (defun counsel--switch-buffer-unwind ()
  4868. "Clear temporary file buffers and restore `buffer-list'.
  4869. The buffers are those opened during a session of `counsel-switch-buffer'."
  4870. (mapc #'kill-buffer counsel--switch-buffer-temporary-buffers)
  4871. (mapc #'bury-buffer (cl-remove-if-not
  4872. #'buffer-live-p
  4873. counsel--switch-buffer-previous-buffers))
  4874. (setq counsel--switch-buffer-temporary-buffers nil
  4875. counsel--switch-buffer-previous-buffers nil))
  4876. (defun counsel--switch-buffer-update-fn ()
  4877. (unless counsel--switch-buffer-previous-buffers
  4878. (setq counsel--switch-buffer-previous-buffers (buffer-list)))
  4879. (let* ((current (ivy-state-current ivy-last))
  4880. (virtual (assoc current ivy--virtual-buffers)))
  4881. (cond
  4882. ((get-buffer current)
  4883. (ivy-call))
  4884. ((and virtual (file-exists-p (cdr virtual)))
  4885. (let ((buf (ignore-errors
  4886. ;; may not open due to `large-file-warning-threshold' etc.
  4887. (find-file-noselect (cdr virtual)))))
  4888. (if buf
  4889. (progn
  4890. (push buf counsel--switch-buffer-temporary-buffers)
  4891. (ivy-call))
  4892. ;; clean up the minibuffer so that there's no delay before
  4893. ;; the Ivy candidates are displayed once again
  4894. (message ""))))
  4895. (t
  4896. (with-ivy-window
  4897. (switch-to-buffer (ivy-state-buffer ivy-last)))))))
  4898. ;;;###autoload
  4899. (defun counsel-switch-buffer ()
  4900. "Switch to another buffer.
  4901. Display a preview of the selected ivy completion candidate buffer
  4902. in the current window."
  4903. (interactive)
  4904. (let ((ivy-update-fns-alist
  4905. '((ivy-switch-buffer . counsel--switch-buffer-update-fn)))
  4906. (ivy-unwind-fns-alist
  4907. '((ivy-switch-buffer . counsel--switch-buffer-unwind))))
  4908. (ivy-switch-buffer)))
  4909. ;;;###autoload
  4910. (defun counsel-switch-buffer-other-window ()
  4911. "Switch to another buffer in another window.
  4912. Display a preview of the selected ivy completion candidate buffer
  4913. in the current window."
  4914. (interactive)
  4915. (let ((ivy-update-fns-alist
  4916. '((ivy-switch-buffer-other-window . counsel--switch-buffer-update-fn)))
  4917. (ivy-unwind-fns-alist
  4918. '((ivy-switch-buffer-other-window . counsel--switch-buffer-unwind))))
  4919. (ivy-switch-buffer-other-window)))
  4920. (defun counsel-open-buffer-file-externally (buffer)
  4921. "Open the file associated with BUFFER with an external program."
  4922. (when (zerop (length buffer))
  4923. (user-error "Can't open that"))
  4924. (let* ((virtual (assoc buffer ivy--virtual-buffers))
  4925. (filename (if virtual
  4926. (cdr virtual)
  4927. (buffer-file-name (get-buffer buffer)))))
  4928. (unless filename
  4929. (user-error "Can't open `%s' externally" buffer))
  4930. (counsel-locate-action-extern (expand-file-name filename))))
  4931. (ivy-add-actions
  4932. 'ivy-switch-buffer
  4933. '(("x" counsel-open-buffer-file-externally "open externally")))
  4934. (ivy-set-actions
  4935. 'counsel-switch-buffer
  4936. '(("x" counsel-open-buffer-file-externally "open externally")
  4937. ("j" ivy--switch-buffer-other-window-action "other window")))
  4938. ;;** `counsel-compile'
  4939. (defvar counsel-compile-history nil
  4940. "History for `counsel-compile'.
  4941. This is a list of strings with additional properties which allow
  4942. the history to be filtered depending on the context of the call.
  4943. The properties include:
  4944. `srcdir'
  4945. the root directory of the source code
  4946. `blddir'
  4947. the root directory of the build (in or outside the `srcdir')
  4948. `bldenv'
  4949. the build environment as passed to `compilation-environment'
  4950. `recursive'
  4951. the completion should be run again in `blddir' of this result
  4952. `cmd'
  4953. if set, pass only the substring with this property to `compile'
  4954. This variable is suitable for addition to
  4955. `savehist-additional-variables'.")
  4956. (defvar counsel-compile-root-functions
  4957. '(counsel--project-current
  4958. counsel--configure-root
  4959. counsel--git-root
  4960. counsel--dir-locals-root)
  4961. "Special hook to find the project root for compile commands.
  4962. Each function on this hook is called in turn with no arguments
  4963. and should return either a directory, or nil if no root was
  4964. found.")
  4965. (defun counsel--compile-root ()
  4966. "Return root of current project or signal an error on failure.
  4967. The root is determined by `counsel-compile-root-functions'."
  4968. (or (run-hook-with-args-until-success 'counsel-compile-root-functions)
  4969. (error "Couldn't find project root")))
  4970. (defun counsel--project-current ()
  4971. "Return root of current project or nil on failure.
  4972. Use `project-current' to determine the root."
  4973. (and (fboundp 'project-current)
  4974. (cdr (project-current))))
  4975. (defun counsel--configure-root ()
  4976. "Return root of current project or nil on failure.
  4977. Use the presence of a \"configure\" file to determine the root."
  4978. (counsel--dominating-file "configure"))
  4979. (defun counsel--git-root ()
  4980. "Return root of current project or nil on failure.
  4981. Use the presence of a \".git\" file to determine the root."
  4982. (counsel--dominating-file ".git"))
  4983. (defun counsel--dir-locals-root ()
  4984. "Return root of current project or nil on failure.
  4985. Use the presence of a `dir-locals-file' to determine the root."
  4986. (counsel--dominating-file dir-locals-file))
  4987. (defvar counsel-compile-local-builds
  4988. '(counsel-compile-get-filtered-history
  4989. counsel-compile-get-build-directories
  4990. counsel-compile-get-make-invocation)
  4991. "Additional compile invocations to feed into `counsel-compile'.
  4992. This can either be a list of compile invocation strings or
  4993. functions that will provide such a list. You should customize
  4994. this if you want to provide specific non-standard build types to
  4995. `counsel-compile'. The default helpers are set up to handle
  4996. common build environments.")
  4997. (defcustom counsel-compile-make-args "-k"
  4998. "Additional arguments for make.
  4999. You may, for example, want to add \"-jN\" for the number of cores
  5000. N in your system."
  5001. :type 'string)
  5002. (defcustom counsel-compile-env nil
  5003. "List of environment variables for compilation to inherit.
  5004. Each element should be a string of the form ENVVARNAME=VALUE. This
  5005. list is passed to `compilation-environment'."
  5006. :type '(repeat (string :tag "ENVVARNAME=VALUE")))
  5007. (defvar counsel-compile-env-history nil
  5008. "History for `counsel-compile-env'.")
  5009. (defvar counsel-compile-env-pattern
  5010. "[_[:digit:][:upper:]]+=[/[:alnum:]]*"
  5011. "Pattern to match valid environment variables.")
  5012. (defcustom counsel-compile-make-pattern "\\`\\(?:GNUm\\|[Mm]\\)akefile\\'"
  5013. "Regexp for matching the names of Makefiles."
  5014. :type 'regexp)
  5015. (defcustom counsel-compile-build-directories
  5016. '("build" "builds" "bld" ".build")
  5017. "List of potential build subdirectory names to check for."
  5018. :type '(repeat directory))
  5019. (defvar counsel-compile-phony-pattern "^\\.PHONY:[\t ]+\\(.+\\)$"
  5020. "Regexp for extracting phony targets from Makefiles.")
  5021. ;; This is loosely based on the Bash Make completion code
  5022. (defun counsel-compile--probe-make-targets (dir)
  5023. "Return a list of Make targets for DIR.
  5024. Return an empty list is Make exits with an error. This might
  5025. happen because some sort of configuration needs to be done first
  5026. or the source tree is pristine and being used for multiple build
  5027. trees."
  5028. (let ((default-directory dir)
  5029. (targets nil))
  5030. (with-temp-buffer
  5031. ;; 0 = no-rebuild, -q & 1 needs rebuild, 2 error (for GNUMake at
  5032. ;; least)
  5033. (when (< (call-process "make" nil t nil "-nqp") 2)
  5034. (goto-char (point-min))
  5035. (while (re-search-forward counsel-compile-phony-pattern nil t)
  5036. (setq targets
  5037. (nconc targets (split-string
  5038. (match-string-no-properties 1)))))))
  5039. (sort targets #'string-lessp)))
  5040. (defun counsel-compile--pretty-propertize (leader text face)
  5041. "Return a pretty string of the form \" LEADER TEXT\".
  5042. LEADER is propertized with a warning face and the remaining
  5043. text with FACE."
  5044. (concat (propertize (concat " " leader " ")
  5045. 'face
  5046. 'font-lock-warning-face)
  5047. (propertize text 'face face)))
  5048. (defun counsel--compile-get-make-targets (srcdir &optional blddir)
  5049. "Return a list of Make targets for a given SRCDIR/BLDDIR combination.
  5050. We search the Makefile for a list of phony targets which are
  5051. generally the top level targets a Make system provides.
  5052. The resulting strings are tagged with properties that
  5053. `counsel-compile-history' can use for filtering results."
  5054. (let ((fmt (format (propertize "make %s %%s" 'cmd t)
  5055. counsel-compile-make-args))
  5056. (suffix (and blddir
  5057. (counsel-compile--pretty-propertize "in" blddir
  5058. 'dired-directory)))
  5059. (build-env (and counsel-compile-env
  5060. (counsel-compile--pretty-propertize
  5061. "with"
  5062. (mapconcat #'identity counsel-compile-env " ")
  5063. 'font-lock-variable-name-face)))
  5064. (props `(srcdir ,srcdir blddir ,blddir bldenv ,counsel-compile-env)))
  5065. (mapcar (lambda (target)
  5066. (setq target (concat (format fmt target) suffix build-env))
  5067. (add-text-properties 0 (length target) props target)
  5068. target)
  5069. (counsel-compile--probe-make-targets (or blddir srcdir)))))
  5070. (defun counsel-compile-get-make-invocation (&optional blddir)
  5071. "Have a look in the root directory for any build control files.
  5072. The optional BLDDIR is useful for other helpers that have found
  5073. sub-directories that builds may be invoked in."
  5074. (let ((srcdir (counsel--compile-root)))
  5075. (when (directory-files (or blddir srcdir) nil
  5076. counsel-compile-make-pattern t)
  5077. (counsel--compile-get-make-targets srcdir blddir))))
  5078. (defun counsel--find-build-subdir (srcdir)
  5079. "Return builds subdirectory of SRCDIR, if one exists."
  5080. (cl-some (lambda (dir)
  5081. (setq dir (expand-file-name dir srcdir))
  5082. (and (file-directory-p dir) dir))
  5083. counsel-compile-build-directories))
  5084. (defun counsel--get-build-subdirs (blddir)
  5085. "Return all subdirs under BLDDIR sorted by modification time.
  5086. If there are non-directory files in BLDDIR, include BLDDIR in the
  5087. list as it may also be a build directory."
  5088. (let* ((files (directory-files-and-attributes
  5089. blddir t directory-files-no-dot-files-regexp t))
  5090. (dirs (cl-remove-if-not #'cl-second files)))
  5091. ;; Any non-dir files?
  5092. (when (< (length dirs)
  5093. (length files))
  5094. (push (cons blddir (file-attributes blddir)) dirs))
  5095. (mapcar #'car (sort dirs (lambda (x y)
  5096. (time-less-p (nth 6 y) (nth 6 x)))))))
  5097. (defun counsel-compile-get-build-directories (&optional dir)
  5098. "Return a list of potential build directories."
  5099. (let* ((srcdir (or dir (counsel--compile-root)))
  5100. (blddir (counsel--find-build-subdir srcdir))
  5101. (props `(srcdir ,srcdir recursive t))
  5102. (fmt (concat (propertize "Select build in "
  5103. 'face 'font-lock-warning-face)
  5104. (propertize "%s" 'face 'dired-directory))))
  5105. (mapcar (lambda (subdir)
  5106. (let ((s (format fmt subdir)))
  5107. (add-text-properties 0 (length s) `(blddir ,subdir ,@props) s)
  5108. s))
  5109. (and blddir (counsel--get-build-subdirs blddir)))))
  5110. ;; This is a workaround for the fact there is no concept of "project"
  5111. ;; local variables (as opposed to for example buffer-local). So we
  5112. ;; store all our history in a global list filter out the results we
  5113. ;; don't want.
  5114. (defun counsel-compile-get-filtered-history (&optional dir)
  5115. "Return a compile history relevant to current project."
  5116. (let ((root (or dir (counsel--compile-root)))
  5117. history)
  5118. (dolist (item counsel-compile-history)
  5119. (let ((srcdir (get-text-property 0 'srcdir item))
  5120. (blddir (get-text-property 0 'blddir item)))
  5121. (when (or (and srcdir (file-in-directory-p srcdir root))
  5122. (and blddir (file-in-directory-p blddir root)))
  5123. (push item history))))
  5124. (nreverse history)))
  5125. (defun counsel--get-compile-candidates (&optional dir)
  5126. "Return the list of compile commands.
  5127. This is determined by `counsel-compile-local-builds', which see."
  5128. (let (cands)
  5129. (dolist (cmds counsel-compile-local-builds)
  5130. (when (functionp cmds)
  5131. (setq cmds (funcall cmds dir)))
  5132. (when cmds
  5133. (push (if (listp cmds) cmds (list cmds)) cands)))
  5134. (apply #'append (nreverse cands))))
  5135. ;; This is a workaround to ensure we tag all the relevant metadata in
  5136. ;; our compile history. This also allows M-x compile to do fancy
  5137. ;; things like infer `default-directory' from 'cd's in the string.
  5138. (defun counsel-compile--update-history (_proc)
  5139. "Update `counsel-compile-history' from the compilation state."
  5140. (let* ((srcdir (counsel--compile-root))
  5141. (blddir default-directory)
  5142. (bldenv compilation-environment)
  5143. (cmd (concat
  5144. (propertize (car compilation-arguments) 'cmd t)
  5145. (unless (file-equal-p blddir srcdir)
  5146. (counsel-compile--pretty-propertize "in" blddir
  5147. 'dired-directory))
  5148. (when bldenv
  5149. (counsel-compile--pretty-propertize "with"
  5150. (mapconcat #'identity bldenv " ")
  5151. 'font-lock-variable-name-face)))))
  5152. (add-text-properties 0 (length cmd)
  5153. `(srcdir ,srcdir blddir ,blddir bldenv ,bldenv) cmd)
  5154. (add-to-history 'counsel-compile-history cmd)))
  5155. (defvar counsel-compile--current-build-dir nil
  5156. "Tracks the last directory `counsel-compile' was called with.
  5157. This state allows us to set it correctly if the user has manually
  5158. edited the command, thus losing our embedded state.")
  5159. (defun counsel-compile--action (cmd)
  5160. "Process CMD to call `compile'.
  5161. If CMD has the `recursive' property set we call `counsel-compile'
  5162. again to further refine the compile options in the directory
  5163. specified by the `blddir' property."
  5164. (let ((blddir (get-text-property 0 'blddir cmd))
  5165. (bldenv (get-text-property 0 'bldenv cmd)))
  5166. (if (get-text-property 0 'recursive cmd)
  5167. (counsel-compile blddir)
  5168. (when (get-char-property 0 'cmd cmd)
  5169. (setq cmd (substring-no-properties
  5170. cmd 0 (next-single-property-change 0 'cmd cmd))))
  5171. (let ((default-directory (or blddir
  5172. counsel-compile--current-build-dir
  5173. default-directory))
  5174. (compilation-environment bldenv))
  5175. ;; No need to specify `:history' because of this hook.
  5176. (add-hook 'compilation-start-hook #'counsel-compile--update-history)
  5177. (unwind-protect
  5178. (compile cmd)
  5179. (remove-hook 'compilation-start-hook #'counsel-compile--update-history))))))
  5180. ;;;###autoload
  5181. (defun counsel-compile (&optional dir)
  5182. "Call `compile' completing with smart suggestions, optionally for DIR."
  5183. (interactive)
  5184. (setq counsel-compile--current-build-dir (or dir
  5185. (counsel--compile-root)
  5186. default-directory))
  5187. (ivy-read "Compile command: "
  5188. (delete-dups (counsel--get-compile-candidates dir))
  5189. :action #'counsel-compile--action
  5190. :caller 'counsel-compile))
  5191. (defun counsel-compile-env--format-hint (cands)
  5192. "Return a formatter for compile-env CANDS."
  5193. (let ((rmstr
  5194. (propertize "remove" 'face 'font-lock-warning-face))
  5195. (addstr
  5196. (propertize "add" 'face 'font-lock-variable-name-face)))
  5197. (ivy--format-function-generic
  5198. (lambda (selected)
  5199. (format "%s %s"
  5200. (if (member selected counsel-compile-env) rmstr addstr)
  5201. selected))
  5202. #'identity
  5203. cands
  5204. "\n")))
  5205. (defun counsel-compile-env--update (var)
  5206. "Update `counsel-compile-env' either adding or removing VAR."
  5207. (cond ((member var counsel-compile-env)
  5208. (setq counsel-compile-env (delete var counsel-compile-env)))
  5209. ((string-match-p counsel-compile-env-pattern var)
  5210. (push var counsel-compile-env))
  5211. (t (user-error "Ignoring malformed variable: '%s'" var))))
  5212. ;;;###autoload
  5213. (defun counsel-compile-env ()
  5214. "Update `counsel-compile-env' interactively."
  5215. (interactive)
  5216. (ivy-read "Compile environment variable: "
  5217. (delete-dups (append
  5218. counsel-compile-env counsel-compile-env-history))
  5219. :action #'counsel-compile-env--update
  5220. :predicate (lambda (cand)
  5221. (string-match-p counsel-compile-env-pattern
  5222. cand))
  5223. :history 'counsel-compile-env-history
  5224. :caller 'counsel-compile-env))
  5225. (ivy-configure 'counsel-compile-env
  5226. :format-fn #'counsel-compile-env--format-hint)
  5227. ;;** `counsel-minor'
  5228. (defvar counsel-minor-history nil
  5229. "History for `counsel-minor'.")
  5230. (defun counsel--minor-candidates ()
  5231. "Return completion alist for `counsel-minor'.
  5232. The alist element is cons of minor mode string with its lighter
  5233. and minor mode symbol."
  5234. (delq nil
  5235. (mapcar
  5236. (lambda (mode)
  5237. (when (and (boundp mode) (commandp mode))
  5238. (let ((lighter (alist-get mode minor-mode-alist)))
  5239. (cons (concat
  5240. (if (symbol-value mode) "-" "+")
  5241. (symbol-name mode)
  5242. (propertize
  5243. (if lighter
  5244. (format " \"%s\""
  5245. (format-mode-line (cons t lighter)))
  5246. "")
  5247. 'face font-lock-string-face))
  5248. mode))))
  5249. minor-mode-list)))
  5250. ;;;###autoload
  5251. (defun counsel-minor ()
  5252. "Enable or disable minor mode.
  5253. Disabled minor modes are prefixed with \"+\", and
  5254. selecting one of these will enable it.
  5255. Enabled minor modes are prefixed with \"-\", and
  5256. selecting one of these will enable it.
  5257. Additional actions:\\<ivy-minibuffer-map>
  5258. \\[ivy-dispatching-done] d: Go to minor mode definition
  5259. \\[ivy-dispatching-done] h: Describe minor mode"
  5260. (interactive)
  5261. (ivy-read "Minor modes (enable +mode or disable -mode): "
  5262. (counsel--minor-candidates)
  5263. :require-match t
  5264. :history 'counsel-minor-history
  5265. :action (lambda (x)
  5266. (call-interactively (cdr x)))))
  5267. (ivy-configure 'counsel-minor
  5268. :initial-input "^+"
  5269. :sort-fn #'ivy-string<)
  5270. (ivy-set-actions
  5271. 'counsel-minor
  5272. `(("d" ,(lambda (x) (find-function (cdr x))) "definition")
  5273. ("h" ,(lambda (x) (describe-function (cdr x))) "help")))
  5274. ;;;###autoload
  5275. (defun counsel-major ()
  5276. (interactive)
  5277. (ivy-read "Major modes: " obarray
  5278. :predicate (lambda (f)
  5279. (and (commandp f) (string-match "-mode$" (symbol-name f))
  5280. (or (and (autoloadp (symbol-function f))
  5281. (let ((doc-split (help-split-fundoc (documentation f) f)))
  5282. ;; major mode starters have no arguments
  5283. (and doc-split (null (cdr (read (car doc-split)))))))
  5284. (null (help-function-arglist f)))))
  5285. :action #'counsel-M-x-action
  5286. :caller 'counsel-major))
  5287. ;;* `counsel-google'
  5288. (declare-function request "ext:request")
  5289. (defun counsel-google-function (input)
  5290. "Create a request to Google with INPUT.
  5291. Return 0 tells `ivy--exhibit' not to update the minibuffer.
  5292. We update it in the callback with `ivy-update-candidates'."
  5293. (or
  5294. (ivy-more-chars)
  5295. (progn
  5296. (require 'request)
  5297. (require 'json)
  5298. (request
  5299. "http://suggestqueries.google.com/complete/search"
  5300. :type "GET"
  5301. :params (list
  5302. (cons "client" "firefox")
  5303. (cons "q" input))
  5304. :parser 'json-read
  5305. :success (cl-function
  5306. (lambda (&key data &allow-other-keys)
  5307. (ivy-update-candidates
  5308. (mapcar #'identity (aref data 1))))))
  5309. 0)))
  5310. (defun counsel-google ()
  5311. "Ivy interface for Google."
  5312. (interactive)
  5313. (ivy-read "search: " #'counsel-google-function
  5314. :action (lambda (x)
  5315. (browse-url (concat "https://www.google.com/search?q=" x)))
  5316. :dynamic-collection t
  5317. :caller 'counsel-google))
  5318. ;;* `counsel-mode'
  5319. (defvar counsel-mode-map
  5320. (let ((map (make-sparse-keymap)))
  5321. (dolist (binding
  5322. '((execute-extended-command . counsel-M-x)
  5323. (describe-bindings . counsel-descbinds)
  5324. (describe-function . counsel-describe-function)
  5325. (describe-variable . counsel-describe-variable)
  5326. (apropos-command . counsel-apropos)
  5327. (describe-face . counsel-describe-face)
  5328. (list-faces-display . counsel-faces)
  5329. (find-file . counsel-find-file)
  5330. (find-library . counsel-find-library)
  5331. (imenu . counsel-imenu)
  5332. (load-library . counsel-load-library)
  5333. (load-theme . counsel-load-theme)
  5334. (yank-pop . counsel-yank-pop)
  5335. (info-lookup-symbol . counsel-info-lookup-symbol)
  5336. (pop-to-mark-command . counsel-mark-ring)
  5337. (bookmark-jump . counsel-bookmark)))
  5338. (define-key map (vector 'remap (car binding)) (cdr binding)))
  5339. map)
  5340. "Map for `counsel-mode'.
  5341. Remaps built-in functions to counsel replacements.")
  5342. (defcustom counsel-mode-override-describe-bindings nil
  5343. "Whether to override `describe-bindings' when `counsel-mode' is active."
  5344. :type 'boolean)
  5345. ;;;###autoload
  5346. (define-minor-mode counsel-mode
  5347. "Toggle Counsel mode on or off.
  5348. Turn Counsel mode on if ARG is positive, off otherwise. Counsel
  5349. mode remaps built-in emacs functions that have counsel
  5350. replacements.
  5351. Local bindings (`counsel-mode-map'):
  5352. \\{counsel-mode-map}"
  5353. :global t
  5354. :keymap counsel-mode-map
  5355. :lighter " counsel"
  5356. (if counsel-mode
  5357. (progn
  5358. (when (and (fboundp 'advice-add)
  5359. counsel-mode-override-describe-bindings)
  5360. (advice-add #'describe-bindings :override #'counsel-descbinds))
  5361. (define-key minibuffer-local-map (kbd "C-r")
  5362. 'counsel-minibuffer-history))
  5363. (when (fboundp 'advice-remove)
  5364. (advice-remove #'describe-bindings #'counsel-descbinds))))
  5365. (provide 'counsel)
  5366. ;;; counsel.el ends here