outline for counsel-ext library

counsel-extra.el

;;; 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