Facilitate creating Git repositories for third-party Quicklisp projects.

ql-gitify.lisp

(defpackage #:snippets/ql-gitify
  (:documentation
   "Facilitate creating Git repositories for third-party Quicklisp
projects.")
  (: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)
  (:export
   #:print-report))

(in-package #:snippets/ql-gitify)

(defun metadata-source-filename (project-name)
  "Return the source.txt pathname corresponding to the supplied
project name."
  (qmerge
   (make-pathname :name "source" :type "txt"
                  :directory (list :relative "third-party"
                                   "quicklisp-projects" "projects"
                                   project-name))))

(defun project-source (project-name)
  "Return the origin of the designated project, or NIL if not
available."
  (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)
        nil)))

(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."
  (probe-file
   (qmerge
    (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
directory."
  (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
following:

  :NO-NAME

    Could not find a project name corresponding to the prefix.  The
    second value is the prefix.

  :CLONED

    The project is already a local third-party project.  The second
    value is a list (name prefix).

  :GIT-CLONE

    The project has a Git repository that can be cloned.  The second
    value is a list (name url [branch]).

  :NOT-GIT

    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)))))
          (t
           (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)))
                             project-names)
                     (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 (:%)
       (:%)))