consult-gh-embark.el (10905B)
1 ;;; consult-gh-embark.el --- Embark Actions for consult-gh -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2021-2023 Free Software Foundation, Inc. 4 5 ;; Author: Armin Darvish 6 ;; Maintainer: Armin Darvish 7 ;; Created: 2023 8 ;; Version: 1.0.0 9 ;; Package-Requires: ((emacs "27.1") (consult "0.34")) 10 ;; Homepage: https://github.com/armindarvish/consult-gh 11 ;; Keywords: matching, git, repositories, forges, completion 12 13 ;;; Commentary: 14 15 ;;; Code: 16 17 ;;; Requirements 18 (require 'embark) 19 (require 'consult-gh) 20 21 ;;; Define Embark Action Functions 22 (defun consult-gh-embark-add-repo-to-known-repos (cand) 23 "Adds repo to `consult-gh--known-repos-list'." 24 (let* ((repo (get-text-property 0 :repo cand))) 25 (add-to-list 'consult-gh--known-repos-list repo)) 26 ) 27 28 (defun consult-gh-embark-remove-repo-from-known-repos (cand) 29 "Removes repo from `consult-gh--known-repos-list'." 30 (let* ((repo (get-text-property 0 :repo cand))) 31 (setq consult-gh--known-repos-list (delete repo consult-gh--known-repos-list)) 32 )) 33 34 (defun consult-gh-embark-add-org-to-known-orgs (cand) 35 "Adds org to `consult-gh--known-orgs-list'." 36 (let* ((org (get-text-property 0 :user cand))) 37 (add-to-list 'consult-gh--known-orgs-list (format "%s" org))) 38 ) 39 40 (defun consult-gh-embark-remove-org-from-known-orgs (cand) 41 "Removes org from `consult-gh--known-orgs-list'." 42 (let* ((org (get-text-property 0 :user cand))) 43 (setq consult-gh--known-orgs-list (delete org consult-gh--known-orgs-list)) 44 ) 45 ) 46 47 (defun consult-gh-embark-add-org-to-default-list (cand) 48 "Adds org to `consult-gh--known-orgs-list'." 49 (let* ((org (get-text-property 0 :user cand))) 50 (add-to-list 'consult-gh-default-orgs-list (format "%s" org))) 51 ) 52 53 (defun consult-gh-embark-remove-org-from-default-list (cand) 54 "Removes org from `consult-gh--known-orgs-list'." 55 (let* ((org (get-text-property 0 :user cand))) 56 (setq consult-gh-default-orgs-list (delete org consult-gh-default-orgs-list)) 57 ) 58 ) 59 60 (defun consult-gh-embark-open-in-browser (cand) 61 "Opens the link in browser" 62 (let* ((repo (get-text-property 0 :repo cand)) 63 (issue (or (get-text-property 0 :issue cand) nil)) 64 (pr (or (get-text-property 0 :pr cand) nil)) 65 (path (or (get-text-property 0 :path cand) nil)) 66 ) 67 (cond 68 (issue 69 (consult-gh--call-process "issue" "view" "--web" "--repo" (substring-no-properties repo) (substring-no-properties issue))) 70 (path 71 (browse-url (concat (string-trim (consult-gh--command-to-string "browse" "--repo" repo "--no-browser")) "/blob/HEAD/" path))) 72 (pr 73 (consult-gh--call-process "pr" "view" "--web" "--repo" (substring-no-properties repo) (substring-no-properties pr))) 74 (t 75 (consult-gh--call-process "repo" "view" "--web" (substring repo)))) 76 )) 77 78 (defun consult-gh-embark-default-action (cand) 79 "Opens the link in an Emacs buffer" 80 (let* ((repo (get-text-property 0 :repo cand)) 81 (user (get-text-property 0 :user cand)) 82 (package (get-text-property 0 :package cand)) 83 (url (or (get-text-property 0 :url cand) nil)) 84 (issue (or (get-text-property 0 :issue cand) nil)) 85 (pr (or (get-text-property 0 :pr cand) nil)) 86 (path (or (get-text-property 0 :path cand) nil)) 87 (branch (or (get-text-property 0 :branch cand) nil)) 88 (code (or (get-text-property 0 :code cand) nil)) 89 (newcand (cons cand `(:repo ,repo :user ,user :package ,package :url ,url :path ,path :branch ,branch :issue ,issue :pr ,pr :code ,code))) 90 ) 91 (cond 92 (code 93 (funcall consult-gh-code-action newcand)) 94 (issue 95 (funcall consult-gh-issue-action newcand)) 96 (pr 97 (funcall consult-gh-pr-action newcand)) 98 (path 99 (funcall consult-gh-file-action newcand)) 100 (t 101 (funcall consult-gh-repo-action newcand))) 102 )) 103 104 105 (defun consult-gh-embark-get-ssh-link (cand) 106 "Copys the ssh based clone link of the repo to `kill-ring'." 107 (kill-new (concat "git@github.com:" (string-trim (get-text-property 0 :repo cand))) ".git")) 108 109 (defun consult-gh-embark-get-https-link (cand) 110 "Copys the http based clone link of the repo to `kill-ring'." 111 (kill-new (concat "https://github.com/" (string-trim (get-text-property 0 :repo cand)) ".git"))) 112 113 (defun consult-gh-embark-get-url-link (cand) 114 "Copys the url link of candidate to `kill-ring'. 115 116 The candidate can be a repo, issue, PR, file path, or a branch." 117 (let* ((repo (get-text-property 0 :repo cand)) 118 (issue (or (get-text-property 0 :issue cand) nil)) 119 (pr (or (get-text-property 0 :pr cand) nil)) 120 (path (or (get-text-property 0 :path cand) nil)) 121 (branch (or (get-text-property 0 :branch cand) nil))) 122 (cond 123 (issue 124 (kill-new (concat (string-trim (consult-gh--command-to-string "browse" "--repo" (string-trim repo) "--no-browser")) (format "/issues/%s" issue)))) 125 (path 126 (kill-new (concat (string-trim (consult-gh--command-to-string "browse" "--repo" repo "--no-browser")) (format "/blob/%s/%s" (or branch "HEAD") path)))) 127 (pr 128 (kill-new (concat (string-trim (consult-gh--command-to-string "browse" "--repo" (string-trim repo) "--no-browser")) (format "/pull/%s" pr)))) 129 (t 130 (kill-new (string-trim (consult-gh--command-to-string "browse" "--repo" (string-trim repo) "--no-browser"))))) 131 )) 132 133 (defun consult-gh-embark-get-org-link (cand) 134 "Copy the org style link for the repo's url to `kill-ring'." 135 (let* ((repo (get-text-property 0 :repo cand)) 136 (url (string-trim (consult-gh--command-to-string "browse" "--repo" (string-trim repo) "--no-browser"))) 137 (package (car (last (split-string repo "\/"))))) 138 (kill-new (concat "[[" url "][" package "]]")))) 139 140 (defun consult-gh-embark-get-straight-usepackage-link (cand) 141 "Copys a drop-in straight use package setup of this repo to `kill-ring'." 142 (let* ((repo (get-text-property 0 :repo cand)) 143 (package (car (last (split-string repo "\/")))) 144 ) 145 (kill-new (concat "(use-package " package "\n\t:straight (" package " :type git :host github :repo \"" repo "\")\n)")))) 146 147 (defun consult-gh-embark-get-other-repos-by-same-user (cand) 148 "List other repos by the same user/organization as the repo at point." 149 (let* ((repo (get-text-property 0 :repo cand)) 150 (user (car (split-string repo "\/")))) 151 (consult-gh-repo-list user))) 152 153 (defun consult-gh-embark-view-issues-of-repo (cand) 154 "Browse issues of the repo at point." 155 (let ((repo (or (get-text-property 0 :repo cand)))) 156 (consult-gh-issue-list repo))) 157 158 (defun consult-gh-embark-view-prs-of-repo (cand) 159 "Browse PRs of the repo at point." 160 (let ((repo (or (get-text-property 0 :repo cand)))) 161 (consult-gh-pr-list repo))) 162 163 (defun consult-gh-embark-view-files-of-repo (cand) 164 "Browses files of the repo at point." 165 (let ((repo (or (get-text-property 0 :repo cand) (consult-gh--nonutf-cleanup cand)))) 166 (consult-gh-find-file repo))) 167 168 (defun consult-gh-embark-clone-repo (cand) 169 "Clones the repo at point." 170 (let ((repo (get-text-property 0 :repo cand))) 171 (funcall #'consult-gh--repo-clone-action (cons repo `(:repo ,repo))))) 172 173 (defun consult-gh-embark-fork-repo (cand) 174 "Forks the repo at point." 175 (let ((repo (get-text-property 0 :repo cand))) 176 (funcall #'consult-gh--repo-fork-action (cons repo `(:repo ,repo))))) 177 178 (defun consult-gh-embark-save-file (cand) 179 "Saves the file at point." 180 (let* ((repo (get-text-property 0 :repo cand)) 181 (path (get-text-property 0 :path cand)) 182 (url (get-text-property 0 :url cand)) 183 (size (get-text-property 0 :size cand))) 184 (funcall #'consult-gh--files-save-file-action (cons path `(:repo ,repo :path ,path :url ,url :size ,size))))) 185 186 ;;; Define Embark Keymaps 187 188 (defvar-keymap consult-gh-embark-general-actions-map 189 :doc "Keymap for consult-gh-embark" 190 :parent embark-general-map 191 "b r r" #'consult-gh-embark-add-repo-to-known-repos 192 "b r k" #'consult-gh-embark-remove-repo-from-known-repos 193 "b o o" #'consult-gh-embark-add-org-to-known-orgs 194 "b o k" #'consult-gh-embark-remove-org-from-known-orgs 195 "b o d" #'consult-gh-embark-add-org-to-default-list 196 "b o D" #'consult-gh-embark-remove-org-from-default-list 197 "f f" #'consult-gh-embark-view-files-of-repo 198 "l h" #'consult-gh-embark-get-https-link 199 "l s" #'consult-gh-embark-get-ssh-link 200 "l l" #'consult-gh-embark-get-url-link 201 "l o" #'consult-gh-embark-get-org-link 202 "l u" #'consult-gh-embark-get-straight-usepackage-link 203 "r c" #'consult-gh-embark-clone-repo 204 "r f" #'consult-gh-embark-fork-repo 205 "r r" #'consult-gh-embark-get-other-repos-by-same-user 206 "r i" #'consult-gh-embark-view-issues-of-repo 207 "r p" #'consult-gh-embark-view-prs-of-repo 208 "o" #'consult-gh-embark-open-in-browser 209 ) 210 211 (add-to-list 'embark-keymap-alist '(consult-gh . consult-gh-embark-general-actions-map)) 212 213 (defvar-keymap consult-gh-embark-orgs-actions-map 214 :doc "Keymap for consult-gh-embark-orgs" 215 :parent consult-gh-embark-general-actions-map) 216 217 (add-to-list 'embark-keymap-alist '(consult-gh-orgs . consult-gh-embark-orgs-actions-map)) 218 219 (defvar-keymap consult-gh-embark-repos-actions-map 220 :doc "Keymap for consult-gh-embark-repos" 221 :parent consult-gh-embark-general-actions-map 222 ) 223 224 (add-to-list 'embark-keymap-alist '(consult-gh-repos . consult-gh-embark-repos-actions-map)) 225 226 227 (defvar-keymap consult-gh-embark-files-actions-map 228 :doc "Keymap for consult-gh-embark-files" 229 :parent consult-gh-embark-general-actions-map 230 "s" #'consult-gh-embark-save-file) 231 232 (add-to-list 'embark-keymap-alist '(consult-gh-files . consult-gh-embark-files-actions-map)) 233 234 (defvar-keymap consult-gh-embark-issues-actions-map 235 :doc "Keymap for consult-gh-embark-repos" 236 :parent consult-gh-embark-general-actions-map 237 ) 238 239 (add-to-list 'embark-keymap-alist '(consult-gh-issues . consult-gh-embark-issues-actions-map)) 240 241 (defvar-keymap consult-gh-embark-prs-actions-map 242 :doc "Keymap for consult-gh-embark-repos" 243 :parent consult-gh-embark-general-actions-map 244 ) 245 246 (add-to-list 'embark-keymap-alist '(consult-gh-prs . consult-gh-embark-prs-actions-map)) 247 248 (defvar-keymap consult-gh-embark-codes-actions-map 249 :doc "Keymap for consult-gh-embark-codes" 250 :parent consult-gh-embark-general-actions-map 251 ) 252 253 (add-to-list 'embark-keymap-alist '(consult-gh-codes . consult-gh-embark-codes-actions-map)) 254 255 (add-to-list 'embark-default-action-overrides '(consult-gh-repos . consult-gh-embark-default-action)) 256 (add-to-list 'embark-default-action-overrides '(consult-gh-issues . consult-gh-embark-default-action)) 257 (add-to-list 'embark-default-action-overrides '(consult-gh-prs . consult-gh-embark-default-action)) 258 (add-to-list 'embark-default-action-overrides '(consult-gh-files . consult-gh-embark-default-action)) 259 (add-to-list 'embark-default-action-overrides '(consult-gh-codes . consult-gh-embark-default-action)) 260 261 ;;; Provide `consul-gh-embark' module 262 263 (provide 'consult-gh-embark) 264 265 ;;; consult-gh-embark.el ends here