├── .gitignore ├── LICENSE ├── README.md ├── TODO ├── build ├── Makefile ├── build.lisp └── make-systems-file.lisp ├── completion.gif ├── quicklisp-systems.el ├── quicklisp-systems.lisp ├── quicksearch.el └── screenshot.png /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *~ 3 | /systems 4 | /quicklisp-systems-list 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2021 Mariano Montone 2 | 3 | This program is free software; you can redistribute it and/or modify 4 | it under the terms of the GNU General Public License as published by 5 | the Free Software Foundation, either version 3 of the License, or 6 | (at your option) any later version. 7 | 8 | This program is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | GNU General Public License for more details. 12 | 13 | You should have received a copy of the GNU General Public License 14 | along with this program. If not, see . -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # quicklisp-systems 2 | 3 | Search, browse and load Quicklisp systems from Emacs. 4 | 5 | ![screenshot](screenshot.png "screenshot") 6 | 7 | ![completion](completion.gif "completion") 8 | 9 | ## Install 10 | 11 | ℹ️ Please consider using [SLIME :star:](https://github.com/mmontone/slime-star), that comes with this extension preinstalled. 12 | 13 | Load `swank` and add this repository path to `swank::*load-path*`, in your Lisp compiler init file (~/.sbclrc if using SBCL): 14 | 15 | ```lisp 16 | (require :swank) 17 | (push #p"/home/marian/src/lisp/quicklisp-systems/" swank::*load-path*) 18 | ``` 19 | 20 | In Emacs, add this repository path to `load-path` and add `quicklisp-systems` to `slime-contribs` in `~/.emacs` init file, like: 21 | 22 | ``` 23 | (push "/home/marian/src/lisp/quicklisp-systems" load-path) 24 | 25 | (setq slime-contribs '(slime-fancy quicklisp-systems)) 26 | 27 | (slime-setup) 28 | ``` 29 | 30 | ## Use 31 | 32 | - `M-x quicklisp-systems-list`: browse the list of Quicklisp systems. 33 | - `M-x quicklisp-systems-apropos`: search both by name and in system descriptions. 34 | - `M-x quicklisp-systems-apropos-name`: search systems by name. 35 | - `M-x quicklisp-systems-apropos-author`: search systems by author. 36 | - `M-x quicklisp-systems-show-system`: show an Emacs buffer with information about the Quicklisp system. 37 | - `M-x quickload`: Load a Quicklisp system, **with completion!**. 38 | - `M-x quicklisp-systems-update`: update the list of Quicklisp systems (this extension downloads a "systems file" with information of ASDF systems in Quicklisp to operate). 39 | 40 | Use `q` to kill individual buffers, and `Q` to kill all quicklisp-systems buffers at once. 41 | 42 | ## Quicksearch 43 | 44 | This repository also contains a simple Emacs frontend for `quicksearch`, that searches for Quicklisp packages on the internet. 45 | 46 | It is available on Quicklisp: `(ql:quickload :quicksearch)`. 47 | 48 | Just load [quicksearch.el](quicksearch.el) in your Emacs, and then use `M-x quicksearch` Emacs command to trigger a search. 49 | 50 | ## License 51 | 52 | GPL 53 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | * Consider using Shinmera's "definitions" library instead of "def-properties". -------------------------------------------------------------------------------- /build/Makefile: -------------------------------------------------------------------------------- 1 | all: build 2 | 3 | quicklisp-projects: 4 | git clone --depth=1 https://github.com/quicklisp/quicklisp-projects.git 5 | 6 | quicklisp-controller: 7 | git clone --depth=1 https://github.com/xach/githappy.git 8 | git clone --depth=1 https://github.com/xach/westbrook.git 9 | git clone --depth=1 https://github.com/quicklisp/project-info.git 10 | git clone --depth=1 https://github.com/quicklisp/quicklisp-controller.git 11 | sbcl --load build.lisp 12 | 13 | systems-file: 14 | sbcl --load 'make-systems-file.lisp' --eval '(quicklisp-systems-file::make-systems-file)' 15 | 16 | build: quicklisp-projects quicklisp-controller systems-file 17 | -------------------------------------------------------------------------------- /build/build.lisp: -------------------------------------------------------------------------------- 1 | (asdf/source-registry:initialize-source-registry 2 | `(:source-registry 3 | (:tree (:here ".")) 4 | :inherit-configuration)) 5 | 6 | (ql:quickload :quicklisp-controller) 7 | 8 | (quicklisp-controller::update-what-you-can) 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /build/make-systems-file.lisp: -------------------------------------------------------------------------------- 1 | ;; This is for buildling a systems-file (the file quicklisp-systems uses to read ASDF systems descriptions.) 2 | 3 | ;; How to build a systems file: 4 | 5 | ;; - Clone quicklisp-projects and quicklisp-controller repositories. 6 | ;; - Setup quicklisp-controller: (quicklisp-controller:setup-directories "~/src/lisp/quicklisp-projects/") 7 | ;; - Update the list of Quicklisp systems using QUICKLISP-CONTROLLER::UPDATE-WHAT-YOU-CAN. 8 | ;; - Load all ASDF systems available in *QUICKLISP-CONTROLLER-DIRECTORY* using REGISTER-ALL-ASDF-FILES 9 | ;; - Use WRITE-SYSTEMS-FILE to serialize to a QUICKLISP-SYSTEM distribution file. 10 | ;; - Compress the file using gzip and upload it to the URL in QUICKLISP-SYSTEMS::*SYSTEMS-FILE-URL* 11 | 12 | (require :quicklisp-systems #p"../quicklisp-systems.lisp") 13 | 14 | (defpackage #:quicklisp-systems-file 15 | (:use #:cl)) 16 | 17 | (in-package #:quicklisp-systems-file) 18 | 19 | (defparameter *quicklisp-controller-directory* #p"~/quicklisp-controller/") 20 | (defvar *failed-asdf-files* nil 21 | "Contains a list of ASDF files that failed to be loaded and the error, after calling REGISTER-ALL-ASDF-FILES.") 22 | (defparameter *conflictive-asdf-files* '("cl-quakeinfo" "qt-libs" "cl-geocode" "cl-geoip") 23 | "Some ASDF files cause conflicts when trying to be loaded. These are ignored.") 24 | 25 | (defun find-files-do (path pattern function &optional (include-subdirectories t)) 26 | "Find files in PATH using PATTERN. Invokes FUNCTION on found files. 27 | If INCLUDE-SUBDIRECTORIES is T, then work recursively." 28 | (dolist (file (uiop/filesystem:directory-files path pattern)) 29 | (funcall function file)) 30 | (when include-subdirectories 31 | (dolist (subdir (uiop/filesystem:subdirectories path)) 32 | (find-files-do subdir pattern function include-subdirectories)))) 33 | 34 | (defun register-all-asdf-files (&optional (quicklisp-controller-directory *quicklisp-controller-directory*)) 35 | "Load all ASDF system definition files found in QUICKLISP-CONTROLLER-DIRECTORY." 36 | (setf *failed-asdf-files* nil) 37 | (format *standard-output* "Finding ASDF files...~%") 38 | (find-files-do 39 | (merge-pathnames #p"upstream-cache/" quicklisp-controller-directory) 40 | "*.asd" 41 | (lambda (file) 42 | ;; conflictive asdf system files 43 | (when (not (some (lambda (conflictive-system-name) 44 | (search conflictive-system-name (princ-to-string file) :test 'equalp)) 45 | *conflictive-asdf-files*)) 46 | (format *standard-output* "Loading ~a" file) 47 | (handler-case (progn 48 | (asdf/find-system:load-asd file) 49 | (format *standard-output* ". Success.~%")) 50 | (error (e) 51 | ;;(error e) 52 | (push (cons file e) *failed-asdf-files*) 53 | (format *standard-output* ". ERROR.~%") 54 | )))))) 55 | 56 | (defun serialize-asdf-systems (systems stream) 57 | "Serialize all ASDF SYSTEMS to STREAM." 58 | (loop for system in systems 59 | do 60 | (prin1 `(:name ,(slot-value system 'asdf/component::name) 61 | :description ,(asdf/component:component-description system) 62 | :long-description ,(asdf/component:component-long-description system) 63 | :author ,(slot-value system 'asdf/system::author) 64 | :mailto ,(slot-value system 'asdf/system::mailto) 65 | :maintainer ,(slot-value system 'asdf/system::maintainer) 66 | :homepage ,(slot-value system 'asdf/system::homepage) 67 | :bug-tracker ,(slot-value system 'asdf/system::bug-tracker) 68 | :version ,(slot-value system 'asdf/system::version) 69 | :license ,(slot-value system 'asdf/system::licence) 70 | :depends-on ,(remove-if-not 'stringp (slot-value system 'asdf/system::depends-on))) 71 | stream) 72 | (terpri stream))) 73 | 74 | (defun write-systems-file (&optional (path quicklisp-systems::*systems-file*)) 75 | (with-open-file (f path :direction :output :external-format :utf-8 76 | :if-exists :supersede) 77 | (serialize-asdf-systems (asdf/system-registry:registered-systems*) 78 | f))) 79 | 80 | (defun make-systems-file () 81 | (register-all-asdf-files) 82 | (write-systems-file)) 83 | -------------------------------------------------------------------------------- /completion.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/quicklisp-systems/e6b3f92d08cdc82fe95e895ca3fc06a08b2d98da/completion.gif -------------------------------------------------------------------------------- /quicklisp-systems.el: -------------------------------------------------------------------------------- 1 | ;;; quicklisp-systems --- Utilities for querying Quicklisp systems. -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (C) 2021 Mariano Montone 4 | 5 | ;; This program is free software; you can redistribute it and/or modify 6 | ;; it under the terms of the GNU General Public License as published by 7 | ;; the Free Software Foundation, either version 3 of the License, or 8 | ;; (at your option) any later version. 9 | 10 | ;; This program is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;; GNU General Public License for more details. 14 | 15 | ;; You should have received a copy of the GNU General Public License 16 | ;; along with this program. If not, see . 17 | 18 | ;;; Commentary: 19 | ;;; Code: 20 | 21 | (require 'slime) 22 | 23 | (defface quicklisp-systems-button 24 | '((t (:box (:line-width 2 :color "dark grey") 25 | :background "light grey" 26 | :foreground "black"))) 27 | "quicklisp-systems face for buttons" 28 | :group 'quicklisp-systems-faces) 29 | 30 | (defface quicklisp-systems-title 31 | '((t :weight bold 32 | :height 1.2 33 | )) 34 | "quicklisp-systems face for system title" 35 | :group 'quicklisp-systems-faces) 36 | 37 | (defface quicklisp-systems-attribute 38 | '((t (:inherit 'bold))) 39 | "quicklisp-systems face for system attribute" 40 | :group 'quicklisp-systems-faces) 41 | 42 | (defcustom quicklisp-systems-search-url 43 | "https://www.google.com/search?q=common lisp " 44 | "URL used to search a Lisp library on the internet." 45 | :type 'string 46 | :group 'quicklisp-systems) 47 | 48 | (defun quicklisp-systems-search-on-the-internet (library-name) 49 | (browse-url (concat quicklisp-systems-search-url library-name))) 50 | 51 | (defun quicklisp-systems--horizontal-line (&rest width) 52 | (make-string (or width 80) ?\u2500)) 53 | 54 | (defun quicklisp-systems--follow-link (button) 55 | "Follow the URL specified by BUTTON." 56 | (browse-url (button-get button 'url))) 57 | 58 | (defun quicklisp-systems--button (text type &rest properties) 59 | ;; `make-text-button' mutates our string to add properties. Copy 60 | ;; TEXT to prevent mutating our arguments, and to support 'pure' 61 | ;; strings, which are read-only. 62 | (setq text (substring-no-properties text)) 63 | (apply #'make-text-button 64 | text nil 65 | :type type 66 | properties)) 67 | 68 | (define-button-type 'quicklisp-systems-link-button 69 | 'action #'quicklisp-systems--follow-link 70 | 'follow-link t 71 | 'help-echo "Follow this link") 72 | 73 | (defun quicklisp-systems--propertize-links (string) 74 | "Convert URL links in strings to buttons." 75 | (replace-regexp-in-string 76 | (rx (group (or string-start space "<")) 77 | (group "http" (? "s") "://" (+? (not (any space)))) 78 | (group (? (any "." ">" ")")) 79 | (or space string-end ">"))) 80 | (lambda (match) 81 | (let ((space-before (match-string 1 match)) 82 | (url (match-string 2 match)) 83 | (after (match-string 3 match))) 84 | (concat 85 | space-before 86 | (quicklisp-systems--button 87 | url 88 | 'quicklisp-systems-link-button 89 | 'url url) 90 | after))) 91 | string)) 92 | 93 | (defun quicklisp-systems--format-text (text) 94 | (quicklisp-systems--propertize-links text)) 95 | 96 | (defun quicklisp-systems--kill-current-buffer () 97 | (interactive) 98 | (kill-buffer (current-buffer))) 99 | 100 | (defun quicklisp-systems-quit () 101 | "Kill all quicklisp-systems buffers at once." 102 | (interactive) 103 | (mapcar 'kill-buffer 104 | (cl-remove-if-not 105 | (lambda (buffer) 106 | (string-prefix-p "*quicklisp-systems" (buffer-name buffer))) 107 | (buffer-list)))) 108 | 109 | (cl-defun quicklisp-systems-apropos (pattern) 110 | "Apropos Quicklisp systems." 111 | (interactive "sQuicklisp apropos: ") 112 | (quicklisp-systems--check-systems-list) 113 | (let ((systems (slime-eval `(quicklisp-systems::apropos-system ,pattern t))) 114 | (buffer-name (format "*quicklisp-systems: apropos %s*" pattern))) 115 | (when (get-buffer buffer-name) 116 | (pop-to-buffer buffer-name) 117 | (cl-return-from quicklisp-systems-apropos)) 118 | (let ((buffer (get-buffer-create buffer-name))) 119 | (with-current-buffer buffer 120 | (quicklisp-systems--print-systems-list systems) 121 | (quicklisp-systems--open-buffer))))) 122 | 123 | (cl-defun quicklisp-systems-apropos-name (pattern) 124 | "Apropos Quicklisp systems by name." 125 | (interactive "sQuicklisp apropos system name: ") 126 | (quicklisp-systems--check-systems-list) 127 | (let ((systems (slime-eval `(quicklisp-systems::apropos-system ,pattern))) 128 | (buffer-name (format "*quicklisp-systems: apropos name %s*" pattern))) 129 | (when (get-buffer buffer-name) 130 | (pop-to-buffer buffer-name) 131 | (cl-return-from quicklisp-systems-apropos-name)) 132 | (let ((buffer (get-buffer-create buffer-name))) 133 | (with-current-buffer buffer 134 | (quicklisp-systems--print-systems-list systems) 135 | (quicklisp-systems--open-buffer))))) 136 | 137 | (cl-defun quicklisp-systems-apropos-author (pattern) 138 | "Apropos Quicklisp systems by author." 139 | (interactive "sQuicklisp apropos author: ") 140 | (quicklisp-systems--check-systems-list) 141 | (let ((systems (slime-eval `(quicklisp-systems::apropos-author ,pattern))) 142 | (buffer-name (format "*quicklisp-systems: apropos author %s*" pattern))) 143 | (when (get-buffer buffer-name) 144 | (pop-to-buffer buffer-name) 145 | (cl-return-from quicklisp-systems-apropos-author)) 146 | (let ((buffer (get-buffer-create buffer-name))) 147 | (with-current-buffer buffer 148 | (quicklisp-systems--print-systems-list systems) 149 | (quicklisp-systems--open-buffer))))) 150 | 151 | (defun quicklisp-load (cl-system-name) 152 | "Load Quicklisp system." 153 | (interactive (list (completing-read 154 | "Quickload: " 155 | (mapcar (lambda (system) (getf system :name)) (slime-eval `(quicklisp-systems::list-all-systems))) 156 | nil nil))) 157 | (message "Loading %s..." cl-system-name) 158 | (slime-eval `(ql:quickload ,cl-system-name)) 159 | (message "%s loaded" cl-system-name)) 160 | 161 | (defalias 'quickload 'quicklisp-load) 162 | 163 | (defun quicklisp-systems--print-systems-list (systems) 164 | (dolist (system systems) 165 | (cl-flet ((show-system (btn) 166 | (ignore btn) 167 | (quicklisp-systems-show-system (cl-getf system :name)))) 168 | (insert-text-button (cl-getf system :name) 169 | 'face 'bold 170 | 'action (function show-system) 171 | 'follow-link t) 172 | (newline) 173 | (when (and (cl-getf system :description) 174 | (stringp (cl-getf system :description))) 175 | (insert (cl-getf system :description)) 176 | (newline))))) 177 | 178 | (defun quicklisp-systems--check-systems-list () 179 | (when (not (slime-eval `(quicklisp-systems::check-systems-list))) 180 | (when (yes-or-no-p "Systems list is empty. Download? ") 181 | (quicklisp-systems-update)))) 182 | 183 | (cl-defun quicklisp-systems-list () 184 | "Show a buffer with all quicklisp systems" 185 | (interactive) 186 | (quicklisp-systems--check-systems-list) 187 | (let ((systems (slime-eval `(quicklisp-systems::list-all-systems))) 188 | (buffer-name "*quicklisp-systems: system list*")) 189 | (when (get-buffer buffer-name) 190 | (pop-to-buffer buffer-name) 191 | (cl-return-from quicklisp-systems-list)) 192 | (let ((buffer (get-buffer-create buffer-name))) 193 | (with-current-buffer buffer 194 | (quicklisp-systems--print-systems-list systems) 195 | (quicklisp-systems--open-buffer))))) 196 | 197 | (defalias 'quicklisp-systems 'quicklisp-systems-list) 198 | 199 | (defun quicklisp-systems-update () 200 | "Update the list of Quicklisp systems." 201 | (interactive) 202 | (message "Downloading list of Quicklisp systems...") 203 | (slime-eval `(quicklisp-systems::download-systems-file)) 204 | (message "Quicklisp systems updated")) 205 | 206 | (defun quicklisp-systems--open-buffer () 207 | (let ((buffer (current-buffer))) 208 | (setq buffer-read-only t) 209 | (buffer-disable-undo) 210 | (set (make-local-variable 'kill-buffer-query-functions) nil) 211 | (goto-char 0) 212 | (quicklisp-systems-mode) 213 | (pop-to-buffer buffer))) 214 | 215 | (cl-defun quicklisp-systems-show-system (cl-system-name) 216 | "Show Quicklisp system CL-SYSTEM-NAME." 217 | (interactive "sShow Quicklisp system: ") 218 | (let ((system (slime-eval `(quicklisp-systems::find-system-info ,cl-system-name))) 219 | (buffer-name (format "*quicklisp-systems: %s*" cl-system-name))) 220 | (when (get-buffer buffer-name) 221 | (pop-to-buffer buffer-name) 222 | (cl-return-from quicklisp-systems-show-system)) 223 | (if (null system) 224 | (error "Quicklisp system not found: %s" cl-system-name) 225 | (let ((buffer (get-buffer-create buffer-name))) 226 | (with-current-buffer buffer 227 | (insert (propertize (cl-getf system :name) 'face 'quicklisp-systems-title)) 228 | (newline 2) 229 | (when (cl-getf system :description) 230 | (insert (quicklisp-systems--format-text (cl-getf system :description))) 231 | (newline 2)) 232 | (when (cl-getf system :author) 233 | (insert (propertize "Author: " 'face 'quicklisp-systems-attribute)) 234 | (if (stringp (cl-getf system :author)) 235 | (insert (cl-getf system :author)) 236 | (dolist (author (cl-getf system :author)) 237 | (insert author " "))) 238 | (newline)) 239 | (when (stringp (cl-getf system :homepage)) 240 | (insert (propertize "Homepage: " 'face 'quicklisp-systems-attribute)) 241 | (insert (quicklisp-systems--format-text (cl-getf system :homepage))) 242 | (newline)) 243 | (when (stringp (cl-getf system :bug-tracker)) 244 | (insert (propertize "Bug tracker: " 'face 'quicklisp-systems-attribute)) 245 | (insert (quicklisp-systems--format-text (cl-getf system :bug-tracker))) 246 | (newline)) 247 | (when (stringp (cl-getf system :version)) 248 | (insert (propertize "Version: " 'face 'quicklisp-systems-attribute)) 249 | (insert (quicklisp-systems--format-text (cl-getf system :version))) 250 | (newline)) 251 | (when (cl-getf system :depends-on) 252 | (insert (propertize "Dependencies: " 'face 'quicklisp-systems-attribute)) 253 | (dolist (dependency (cl-getf system :depends-on)) 254 | (insert-button dependency 255 | 'action (lambda (btn) 256 | (ignore btn) 257 | (quicklisp-systems-show-system dependency)) 258 | 'follow-link t) 259 | (insert " ")) 260 | (newline)) 261 | (newline) 262 | 263 | ;; buttons 264 | (insert-button "Load" 265 | 'action (lambda (btn) 266 | (ignore btn) 267 | (quicklisp-load cl-system-name)) 268 | 'follow-link t 269 | 'help-echo "Load Quicklisp system" 270 | 'face 'quicklisp-systems-button) 271 | (when (not (stringp (cl-getf system :homepage))) 272 | (insert " ") 273 | (insert-button "Search on the internet" 274 | 'action (lambda (btn) 275 | (ignore btn) 276 | (quicklisp-systems-search-on-the-internet cl-system-name)) 277 | 'follow-link t 278 | 'help-echo "Search the library on the internet" 279 | 'face 'quicklisp-systems-button)) 280 | (newline 2) 281 | 282 | (when (cl-getf system :long-description) 283 | (insert (quicklisp-systems--horizontal-line)) 284 | (newline 2) 285 | (insert (quicklisp-systems--format-text (cl-getf system :long-description))) 286 | (newline 2)) 287 | 288 | (quicklisp-systems--open-buffer)))))) 289 | 290 | ;; (quicklisp-systems-show-system "hunchentoot") 291 | ;; (quicklisp-systems-show-system "ten") 292 | 293 | (defvar quicklisp-systems-mode-map 294 | (let ((map (make-keymap))) 295 | (define-key map "q" 'quicklisp-systems--kill-current-buffer) 296 | (define-key map "Q" 'quicklisp-systems-quit) 297 | map)) 298 | 299 | (define-minor-mode quicklisp-systems-mode 300 | "Quicklisp systems minor mode." 301 | :init-value nil 302 | :lighter " QuicklispSystems" 303 | :keymap quicklisp-systems-mode-map 304 | :group 'quicklisp-systems) 305 | 306 | (easy-menu-define 307 | quicklisp-systems-mode-menu quicklisp-systems-mode-map 308 | "Menu for Quicklisp systems." 309 | '("Quicklisp" 310 | ["List all systems" quicklisp-systems-list 311 | :help "List all available Quicklisp systems"] 312 | ["Show system..." quicklisp-systems-show-system 313 | :help "Show information about Quicklisp system"] 314 | "---" 315 | ["Apropos..." quicklisp-systems-apropos 316 | :help "Search a system in Quicklisp"] 317 | ["Apropos name..." quicklisp-systems-apropos-name 318 | :help "Search Quicklisp systems by name"] 319 | ["Apropos author..." quicklisp-systems-apropos-author 320 | :help "Search Quicklisp systems by author"] 321 | "---" 322 | ["Load system..." quicklisp-load 323 | :help "Quickload a system"] 324 | ["Update systems list" quicklisp-systems-update 325 | :help "Update the list of Quicklisp systems"] 326 | ["Quit" quicklisp-systems-quit 327 | :help "Quit Quicklisp systems"])) 328 | 329 | (defun quicklisp-systems--add-to-slime-menu () 330 | (easy-menu-add-item 'menubar-slime nil '("---")) 331 | (easy-menu-add-item 'menubar-slime nil 332 | '("Quicklisp" 333 | ["Browse systems" quicklisp-systems 334 | :help "Open Quicklisp systems list"] 335 | ["Load system..." quicklisp-load 336 | :help "Quickload a system"]))) 337 | 338 | (define-slime-contrib quicklisp-systems 339 | "Manage Quicklisp from Emacs" 340 | (:authors "Mariano Montone") 341 | (:license "GPL") 342 | (:swank-dependencies quicklisp-systems) 343 | (:on-load 344 | (quicklisp-systems--add-to-slime-menu))) 345 | 346 | (provide 'quicklisp-systems) 347 | 348 | ;;; quicklisp-systems.el ends here 349 | -------------------------------------------------------------------------------- /quicklisp-systems.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright (C) 2021 Mariano Montone 2 | 3 | ;; This program is free software; you can redistribute it and/or modify 4 | ;; it under the terms of the GNU General Public License as published by 5 | ;; the Free Software Foundation, either version 3 of the License, or 6 | ;; (at your option) any later version. 7 | 8 | ;; This program is distributed in the hope that it will be useful, 9 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;; GNU General Public License for more details. 12 | 13 | ;; You should have received a copy of the GNU General Public License 14 | ;; along with this program. If not, see . 15 | 16 | (require :dexador) 17 | (require :asdf) 18 | (require :quicklisp) 19 | (require :chipz) 20 | 21 | (defpackage #:quicklisp-systems 22 | (:use #:cl)) 23 | 24 | (in-package #:quicklisp-systems) 25 | 26 | (defvar *systems-file* (merge-pathnames "quicklisp-systems-list" (uiop/pathname:pathname-directory-pathname *load-pathname*))) 27 | (defparameter *systems-file-url* "https://github.com/mmontone/quicklisp-systems/releases/latest/download/quicklisp-systems-list.gz" 28 | "The URL from where to download the file with Quicklisp systems descriptions.") 29 | 30 | (defmacro do-systems ((system &optional (path *systems-file*)) &body body) 31 | (let ((f (gensym))) 32 | `(when (probe-file ,path) 33 | (with-open-file (,f ,path :direction :input :external-format :utf-8) 34 | (loop for ,system := (read ,f nil nil) 35 | while ,system 36 | do ,@body))))) 37 | 38 | (defun check-systems-list () 39 | (and (probe-file *systems-file*) t)) 40 | 41 | (defun list-all-systems () 42 | (let (systems) 43 | (do-systems (system) 44 | (push system systems)) 45 | (sort systems 'string< :key (lambda (x) (getf x :name))))) 46 | 47 | (defun find-system-info (name) 48 | (do-systems (system) 49 | (when (equalp (getf system :name) name) 50 | (return-from find-system-info system)))) 51 | 52 | (defun apropos-system (string &optional search-description) 53 | (let (systems) 54 | (do-systems (system) 55 | (when (or (search string (getf system :name) :test 'equalp) 56 | (and search-description 57 | (or (and (getf system :description) 58 | (search string (getf system :description) :test 'equalp)) 59 | (and (getf system :long-description) 60 | (search string (getf system :long-description) :test 'equalp))))) 61 | (push system systems))) 62 | systems)) 63 | 64 | (defun apropos-author (author-name) 65 | (let (systems) 66 | (do-systems (system) 67 | (when (and (getf system :author) 68 | (search author-name (getf system :author) :test 'equalp)) 69 | (push system systems))) 70 | systems)) 71 | 72 | (defun gunzip (gzip-filename output-filename) 73 | (with-open-file (gzstream gzip-filename :direction :input 74 | :element-type '(unsigned-byte 8)) 75 | (with-open-file (stream output-filename :direction :output 76 | :element-type '(unsigned-byte 8) 77 | :if-exists :supersede) 78 | (chipz:decompress stream 'chipz:gzip gzstream) 79 | output-filename))) 80 | 81 | (defun download-systems-file (&optional (url *systems-file-url*)) 82 | (format t "Downloading quicklisp systems file from ~a ~%" url) 83 | (ql-util:with-temporary-file (systems-file-list.gz (pathname-name *systems-file*)) 84 | (dex:fetch url systems-file-list.gz) 85 | (gunzip systems-file-list.gz *systems-file*)) 86 | (format t "Systems file downloaded to ~a~%" *systems-file*)) 87 | 88 | (provide :quicklisp-systems) 89 | -------------------------------------------------------------------------------- /quicksearch.el: -------------------------------------------------------------------------------- 1 | ;; Copyright (C) 2021 Mariano Montone 2 | 3 | ;; This program is free software; you can redistribute it and/or modify 4 | ;; it under the terms of the GNU General Public License as published by 5 | ;; the Free Software Foundation, either version 3 of the License, or 6 | ;; (at your option) any later version. 7 | 8 | ;; This program is distributed in the hope that it will be useful, 9 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 | ;; GNU General Public License for more details. 12 | 13 | ;; You should have received a copy of the GNU General Public License 14 | ;; along with this program. If not, see . 15 | 16 | ;; Install: 17 | ;; Emacs side: just put this file in your load-path and load it on init. 18 | ;; Lisp side: add (require :quicksearch) to your compiler init file (i.e. .sbclrc). 19 | ;; NOTE: 20 | ;; Current quicksearch is buggy for some results. 21 | ;; I recommend you apply this patch: https://github.com/tkych/quicksearch/issues/10 22 | 23 | ;; Use: 24 | ;; M-x quicksearch 25 | ;; Customize max results with: M-x customize-variable RET quicksearch-max-results RET 26 | 27 | (require 'slime) 28 | 29 | (defcustom quicksearch-max-results 500 30 | "Maximum number of results to be returned by Quicksearch.") 31 | 32 | (defun quicksearch--follow-link (button) 33 | "Follow the URL specified by BUTTON." 34 | (browse-url (button-get button 'url))) 35 | 36 | (defun quicksearch--button (text type &rest properties) 37 | ;; `make-text-button' mutates our string to add properties. Copy 38 | ;; TEXT to prevent mutating our arguments, and to support 'pure' 39 | ;; strings, which are read-only. 40 | (setq text (substring-no-properties text)) 41 | (apply #'make-text-button 42 | text nil 43 | :type type 44 | properties)) 45 | 46 | (define-button-type 'quicksearch-link-button 47 | 'action #'quicksearch--follow-link 48 | 'follow-link t 49 | 'help-echo "Follow this link") 50 | 51 | (defun quicksearch--propertize-links (string) 52 | "Convert URL links in strings to buttons." 53 | (replace-regexp-in-string 54 | (rx (group (or string-start space "<")) 55 | (group "http" (? "s") "://" (+? (not (any space)))) 56 | (group (? (any "." ">" ")")) 57 | (or space string-end ">"))) 58 | (lambda (match) 59 | (let ((space-before (match-string 1 match)) 60 | (url (match-string 2 match)) 61 | (after (match-string 3 match))) 62 | (concat 63 | space-before 64 | (quicksearch--button 65 | url 66 | 'quicksearch-link-button 67 | 'url url) 68 | after))) 69 | string)) 70 | 71 | (defun quicksearch (what) 72 | (interactive "sQuicksearch: ") 73 | 74 | (let* ((results 75 | (slime-eval `(cl:with-output-to-string (cl:*standard-output*) 76 | (quicksearch:quicksearch ,what :?url t :?description t 77 | :?cut-off ,quicksearch-max-results)))) 78 | (buffer-name (format "*quicksearch: %s*" what)) 79 | (buffer (get-buffer-create buffer-name))) 80 | (with-current-buffer buffer 81 | (insert (quicksearch--propertize-links results)) 82 | (local-set-key "q" 'kill-buffer) 83 | (setq buffer-read-only t) 84 | (buffer-disable-undo) 85 | (goto-char 0) 86 | (pop-to-buffer buffer)))) 87 | 88 | (provide 'quicksearch) 89 | -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mmontone/quicklisp-systems/e6b3f92d08cdc82fe95e895ca3fc06a08b2d98da/screenshot.png --------------------------------------------------------------------------------