Created
April 1, 2019 11:11
-
-
Save jchaffin/42f2dea43c8469ad108c9d9dd3f80b7a to your computer and use it in GitHub Desktop.
outline for counsel-ext library
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;;; counsel-extra.el --- -*- coding: utf-8; lexical-binding: t -*- | |
;; Copyright © 2019, Jacob Chaffin, all rights reserved. | |
;; Version: 0.0.1 | |
;; Author: Jacob Chaffin -- <jchaffin@ucla.edu> | |
;; URL: https://github.com/jchaffin/counsel-extras | |
;; Created: 1 April 2019 | |
;; Keywords: | |
;; Package-Requires ((emacs "24.3") (ivy "0.11.0") (ht "2.2") (straight "1.0")) | |
;; This program is free software; you can redistribute it and/or | |
;; modify it under the terms of the GNU General Public License as | |
;; published by the Free Software Foundation; either version 2 of | |
;; the License, or (at your option) any later version. | |
;; This program is distributed in the hope that it will be | |
;; useful, but WITHOUT ANY WARRANTY; without even the implied | |
;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR | |
;; PURPOSE. See the GNU General Public License for more details. | |
;;; Commentary: | |
;; Extensions for ivy via counsel. | |
;; | |
;;; Code: | |
(defgroup counsel-ext nil | |
"Counsel extensions." | |
:group 'counsel | |
:prefix "counsel-ext") | |
(defcustom counsel-ext--pkg-file (no-littering-expand-var-file-name "counsel/pkg-data.el") | |
"File used to store package data." | |
:type 'file | |
:group 'counsel-ext) | |
(require 'ht) | |
(require 'ivy-rich) | |
(defun counsel-brew--docstring (pkg) | |
(nth 1 (split-string (shell-command-to-string (concat "brew info " pkg)) "\n"))) | |
(defun counsel-brew-populate (table) | |
(let ((pkgs (split-string (shell-command-to-string "brew search")))) | |
(dolist (pkg pkgs) | |
(ht-set! table pkg (counsel-brew--docstring pkg))))) | |
(defun counsel-ext-ht-from-file () | |
(with-temp-buffer | |
(insert-file-contents counsel-ext--pkg-file) | |
(goto-char (point-min)) | |
(read (current-buffer)))) | |
(defvar counsel-ext-pkgs (counsel-ext-ht-from-file) | |
"Hash table where keys are system package names and values are descriptions.") | |
(defun counsel-ext-pkg-docstring (candidate) | |
(ht-get counsel-ext-pkgs candidate)) | |
(setq ivy-rich-display-transformers-list | |
(append ivy-rich-display-transformers-list | |
'(counsel-pkg | |
(:columns | |
((ivy-rich-candidate (:width 40 :face bold)) | |
(counsel-ext-pkg-docstring (:face font-lock-doc-face))))))) | |
(defun counsel-ext-pkg-candidates () | |
(sort (ht-keys counsel-ext-pkgs) #'string-lessp)) | |
;;;###autoload | |
(defun counsel-pkg () | |
"Issue system package commands via ivy." | |
(interactive) | |
(ivy-read "Package:" (counsel-ext-pkg-candidates) | |
:require-match t | |
:action | |
'(1 | |
("I" (lambda (candidate) | |
(interactive) | |
(system-packages-install candidate arg)) "install") | |
;; TODO Install with args. see `counsel-org-tag-action'. | |
("s" (lambda (candidate) | |
(interactive) | |
(system-packages-search candidate)) "search") | |
("d" (lambda (candidate) | |
(system-packages-get-info candidate)) "info") | |
("D" (lambda (candidate) | |
(interactive) | |
(system-packages-list-dependencies-of candidate)) | |
"dependencies")))) | |
;;;; * counsel straight | |
(require 'counsel) | |
(require 'dash) | |
(require 'dash-functional) | |
(require 'straight) | |
(require 'straight-x) | |
(declare-function straight-x-existing-repos "straight-x") | |
(declare-function straight--repository-is-available-p "straight") | |
(defalias #'counsel--straight-sort #'counsel--package-sort) | |
(defun counsel-straight--installed () | |
(--map (plist-get it :local-repo) (straight-x-existing-repos))) | |
(defun straight-installed-packages () | |
(--> straight--recipe-cache | |
(hash-table-keys it) | |
(seq-difference it (mapcar #'symbol-name straight-built-in-pseudo-packages)) | |
(sort it #'string-lessp))) | |
(defun straight-installed-p (recipe) | |
(or (null (plist-get recipe :local-repo)) | |
(not (straight--repository-is-available-p recipe)))) | |
(defun counsel-straight--candidates (&optional installed for-build) | |
(let ((packages nil)) | |
(maphash | |
(lambda (package recipe) | |
(unless (or (and for-build (plist-get recipe :no-build)) | |
(and installed (or (null (plist-get recipe :local-repo)) | |
(not (straight--repository-is-available-p recipe))))) | |
(push package packages))) | |
straight--recipe-cache) | |
(sort (--map (cons (if (straight-installed-p it) "-" "+") it)) packages))) | |
(defun counsel-straight-action (pkg) | |
(let ((state (string-to-char (cdr pkg)))) | |
(cond ((char-equal ?- state) (message "remote %s" pkg)) | |
((char-equal ?+ state) (message "local %s" pkg)) | |
(t (error "expected: '+' or '-'. got: %s" state))))) | |
(defun straight-installed-p (pkg) | |
(member (symbol-name pkg) (straight-installed-packages))) | |
(defvar counsel-straight-history) | |
(defun counsel-straight--resolve-path (&rest paths) | |
"Concatenate path segments." | |
(let ((paths- (mapcar #'directory-file-name paths))) | |
(mapconcat 'identity paths- "/"))) | |
(defun counsel-straight---local-strategy (package) | |
(let* ((type (or (get-text-property 1 package) "repos")) | |
(dir (resolve-path user-emacs-directory "straight" type))) | |
(condition-case nil | |
(multiple-value-bind (pkg-directory pkg-file) | |
(if (and (string= "build" type) (plist-get (gethash package straight--recipe-cache) :no-build)) | |
(list (file-directory-p (expand-file-name package dir)) nil) | |
(let ((repo (plist-get (gethash package straight--recipe-cache) :local-repo)) | |
(if repo | |
(list (expand-file-name repo (replace-regexp-in-string "build" "repos" dir)) | |
(car (directory-files pkg-directory t (concat "\\README.*\\'\\|" package ".el")))) | |
(let ((library-path (file-name-directory (locate-library package))) | |
(re (concat package ".el\\(?:.gz\\)"))) | |
(list library-path (car (directory-files library-path t re)))))))) | |
(if pkg-file | |
(and (file-exists-p pkg-file) (find-file pkg-file)) | |
(and (file-directory-p pkg-directory) (dired pkg-directory))))))) | |
(defun counsel-straight-local () | |
"Go to an installed recipe source directory." | |
(interactive "P") | |
(let* ((type (if current-prefix-arg "build" "repos")) | |
(msg (format "(%s) Goto recipe: " (upcase-initials type))) | |
(pkgs (straight--installed-packages))) | |
(ivy-read msg (--map (propertize it 'type type) pkgs) | |
:require-match t | |
:sort t | |
:action (lambda (x) (funcall counsel-straight--local-strategy x))))) | |
(defun counsel-straight--remote-url (pkg) | |
"Return the remote URL for PKG if its recipe host is a registered type. | |
Currently, host must be either 'git or 'gitlab." | |
(let ((recipe (cdr (straight-recipes-retrieve pkg)))) | |
(destructuring-bind (repo host) | |
`(,(plist-get recipe :repo) | |
,(plist-get recipe :host)) | |
(cond ((eq host 'github) (concat "https://github.com/" repo)) | |
((eq host 'gitlab) (concat "https://gitlab.com/" repo)) | |
(t (error "Unknown remote for recipe type: %s" repo)))))) | |
(defun counsel-straight--remote-action (pkg) | |
(browse-url (intern (counsel-straight--remote-url pkg)))) | |
(defun counsel-straight-remote () | |
"View a recipe PACKAGE on GitHub." | |
(interactive) | |
(ivy-read "Recipe: " (counsel-straight--candidates) | |
:require-match t | |
:sort t | |
:preselect (ivy-thing-at-point) | |
:action (lambda (x) (funcall counsel-straight--remote-action x)) | |
:caller 'counsel-straight-remote | |
:history 'counsel-straight-history)) | |
;;;###autoload | |
(defun counsel-straight () | |
(interactive) | |
(let ((enable-recursive-minibuffers t)) | |
(ivy-read "Packages (install +pkg or delete -pkg): " (counsel-straight--candidates) | |
:action | |
'(1 | |
("I" (lambda (x) | |
(funcall counsel-straight-action x) "install/uninstall")) | |
("b" (lambda (x) | |
(funcall counsel-straight-browse-action x) "browse"))) | |
:require-match t | |
:preselect (ivy-thing-at-point) | |
:sort t | |
:caller 'counsel-straight | |
:history 'counsel-straight-history))) | |
(provide 'counsel-extra) | |
;;; counsel-extra.el ends here |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment