Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
Facilitate creating Git repositories for third-party Quicklisp projects.
(defpackage #:snippets/ql-gitify
"Facilitate creating Git repositories for third-party Quicklisp
(:use #:cl)
(:import-from #:constantia #:out #:print-table)
(:import-from #:split-sequence #:split-sequence)
(:import-from #:alexandria #:starts-with-subseq #:hash-table-plist)
(:import-from #:ql #:qmerge)
(in-package #:snippets/ql-gitify)
(defun metadata-source-filename (project-name)
"Return the source.txt pathname corresponding to the supplied
project name."
(make-pathname :name "source" :type "txt"
:directory (list :relative "third-party"
"quicklisp-projects" "projects"
(defun project-source (project-name)
"Return the origin of the designated project, or NIL if not
(with-open-file (source-file (metadata-source-filename project-name)
:direction :input
:if-does-not-exist nil)
(when source-file
(split-sequence #\Space (read-line source-file)
:remove-empty-subseqs t))))
(defun git-clone-url (project-name)
"Return the git-clone URL for the designated project, or NIL if not
available. If a specific branch should be cloned, return it as the
second value."
(destructuring-bind (&optional type url branch) (project-source project-name)
(if (or (equal type "git")
(equal type "branched-git")
(equal type "latest-github-tag")
(equal type "latest-github-release"))
(values url branch)
(defun make-prefix-map ()
"Return a hash-table for mapping project directory
names ('prefixes') to project names."
(with-open-file (releases-file (qmerge "dists/quicklisp/releases.txt")
:direction :input
:if-does-not-exist :error)
(loop with map = (make-hash-table :test 'equal)
for line = (read-line releases-file nil)
while line
unless (starts-with-subseq "#" line)
do (destructuring-bind (project url size file-md5 content-sha1
prefix &rest system-files)
(split-sequence #\Space line)
(declare (ignore url size file-md5 content-sha1 system-files))
(setf (gethash prefix map) project))
finally (return map))))
(defun prefix-to-project-name (prefix)
"Return the project name corresponding to the supplied prefix, or
NIL if there's no correspondence."
(let ((table (load-time-value (make-prefix-map))))
(values (gethash prefix table))))
(defun clonedp (project-name)
"Return true if there is a directory corresponding to PROJECT-NAME
in the 3rdparty projects directory, and false otherwise."
(make-pathname :directory (list :relative "third-party" project-name)))))
(defun list-directory-children (directory)
"Return a list of strings naming files and directories within the
supplied directory."
(mapcar (lambda (pathname) (string-right-trim "/" (enough-namestring pathname directory)))
(directory (make-pathname :name :wild :type :wild :defaults directory))))
(defun list-current-prefixes ()
"Return a list of the prefixes in the Quicklisp dist software
(list-directory-children (qmerge "dists/quicklisp/software/")))
(defun categorize (list categorizer)
"Return a plist whose keys are categories and values are lists of
transformed items.
The categorizer should be a function taking an item from the list and
returning two values: the category and the possibly transformed item.
The categories will be tested for equality using EQUAL."
(let ((table (make-hash-table :test 'equal)))
(dolist (item list)
(multiple-value-bind (category transformed-item)
(funcall categorizer item)
(push transformed-item (gethash category table))))
(hash-table-plist table)))
(defun categorize-prefix (prefix)
"Given a prefix, return two values, the first of which is one of the
Could not find a project name corresponding to the prefix. The
second value is the prefix.
The project is already a local third-party project. The second
value is a list (name prefix).
The project has a Git repository that can be cloned. The second
value is a list (name url [branch]).
The project's source is not a Git repository. The second value is
the project's name."
(let ((project-name (prefix-to-project-name prefix))
(url nil)
(branch nil))
(cond ((null project-name)
(values :no-name prefix))
((clonedp project-name)
(values :cloned
(list project-name prefix)))
((multiple-value-setq (url branch)
(git-clone-url project-name))
(values :git-clone
(list* project-name url (when branch (list branch)))))
(values :not-git project-name)))))
(defun categorize-projects (&optional (prefixes (list-current-prefixes)))
"Return a plist whose keys are categories and values are lists of
project entries appropriate to each category."
(categorize prefixes #'categorize-prefix))
(define-modify-macro sortf (predicate &rest args) sort)
(defgeneric print-report-section (category entries)
(:documentation "Report about the entries in the category."))
(defun print-report (&optional (projects (categorize-projects)))
"Print a report for the categorized projects."
(flet ((section (category &key (sort-key #'identity))
(when (getf projects category)
(sortf (getf projects category) #'string< :key sort-key)
(print-report-section category (getf projects category)))))
(section :no-name)
(section :cloned :sort-key #'first)
(section :not-git)
(section :git-clone :sort-key #'first)))
(defmethod print-report-section ((category (eql :no-name)) prefixes)
(out (:&) "The following projects have no names in releases.txt:"
(:%) (:s prefixes :separator #\Newline :prefix " ")
(defmethod print-report-section ((category (eql :cloned)) entries)
(out (:&) "The following projects were already cloned:"
(:%) (:s entries :separator #\Newline :prefix " " :key #'first)
(defmethod print-report-section ((category (eql :not-git)) project-names)
(out (:&) "The following projects are not using Git:"
(print-table '("Name" "Method" "URL")
(sort (mapcar (lambda (name) (cons name (project-source name)))
(lambda (a b)
(cond ((string< (second a) (second b)) t)
((string> (second a) (second b)) nil)
((string< (first a) (first b)) t)
(t nil)))))
(out (:%)))
(defmethod print-report-section ((category (eql :git-clone)) entries)
(out (:&) "Commands for git-cloning:"
(loop for (name url branch) in entries
do (out (:%) " git clone "
(:q (branch "-b " branch " "))
url " " name))
(out (:%)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.