Merge pull request #297 from fukamachi/asdf-version-lock

Add `asdf` source to use a newer ASDF.

README.markdown

@@ -340,7 +340,7 @@ Here are few useful commands:
 <source> <project name> [arg1, arg2..]
 ```
 
-Currently, `<source>` must be one of `dist`, `ql`, `ultralisp`, `http`, `git` or `github`.
+Currently, `<source>` must be one of `dist`, `ql`, `ultralisp`, `http`, `git`, `github`, `local` or `asdf`.
 
 ### ql
 
@@ -445,6 +445,18 @@ Add a directory to the ASDF's source registry.
 local rove ~/Programs/lib/rove
 ```
 
+### asdf (Experimental)
+
+```
+asdf <version>
+```
+
+Use a newer version of ASDF.
+
+```
+asdf 3.3.7.1
+```
+
 ### dist
 
 ```

src/check.lisp

@@ -6,6 +6,7 @@
                 #:source-dist-name
                 #:source-version
                 #:source-local
+                #:source-asdf
                 #:defrost-source
                 #:make-source)
   (:import-from #:qlot/parser
@@ -94,22 +95,40 @@
         (with-package-functions #:ql-dist (find-dist version)
           (let ((old-sources
                   (remove-if (lambda (source)
-                               (if (typep source 'source-local)
-                                   source-registry-up-to-date
-                                   (let ((dist (find-dist (source-dist-name source))))
-                                     (and dist
-                                          (slot-boundp source 'qlot/source/base::version)
-                                          (equal (version dist)
-                                                 (source-version source))))))
+                               (typecase source
+                                 (source-local
+                                  source-registry-up-to-date)
+                                 (source-asdf
+                                  (let ((asdf-dir (merge-pathnames #P"local-projects/asdf/" qlhome)))
+                                    (and (uiop:directory-exists-p asdf-dir)
+                                         (let ((version-file (merge-pathnames #P"version.lisp-expr" asdf-dir)))
+                                           ;; XXX: Skip if the version file doesn't exist.
+                                           (or (not (uiop:file-exists-p version-file))
+                                               (ignore-errors
+                                                 (equal (uiop:read-file-form version-file)
+                                                        (source-version source))))))))
+                                 (otherwise
+                                  (let ((dist (find-dist (source-dist-name source))))
+                                    (and dist
+                                         (slot-boundp source 'qlot/source/base::version)
+                                         (equal (version dist)
+                                                (source-version source)))))))
                              sources)))
             (when old-sources
               (error 'missing-projects
                      :projects (mapcar #'source-project-name old-sources)))))
         (with-package-functions #:ql-dist (all-dists name)
           (let ((extra-dists
-                  (remove-if (lambda (dist-name)
-                               (find dist-name sources :test #'string= :key #'source-dist-name))
-                             (mapcar #'name (all-dists)))))
+                  (append
+                   (remove-if (lambda (dist-name)
+                                (find dist-name sources :test #'string= :key #'source-dist-name))
+                              (mapcar #'name (all-dists)))
+                   (and (not (find-if (lambda (source)
+                                        (typep source 'source-asdf))
+                                      sources))
+                        (let ((asdf-dir (merge-pathnames #P"local-projects/asdf/" qlhome)))
+                          (and (uiop:directory-exists-p asdf-dir)
+                               (list "asdf")))))))
             (when extra-dists
               (error 'unnecessary-projects
                      :projects extra-dists)))))))

src/cli.lisp

@@ -524,7 +524,7 @@ OPTIONS:
 
       ;; Complete the source type
       (unless (member (first argv)
-                      '("dist" "git" "github" "http" "local" "ql" "ultralisp")
+                      '("dist" "git" "github" "http" "local" "ql" "ultralisp" "asdf")
                       :test 'equal)
         (setf argv
               (if (find #\/ (first argv) :test 'char=)

src/install.lisp

@@ -11,6 +11,8 @@
                 #:source-local
                 #:source-local-path
                 #:source-local-registry-directive
+                #:source-asdf
+                #:source-asdf-remote-url
                 #:source-project-name
                 #:source-version
                 #:source-install-url
@@ -61,6 +63,9 @@
   (:import-from #:qlot/utils/tmp
                 #:tmp-directory
                 #:delete-tmp-directory)
+  (:import-from #:qlot/utils/git
+                #:git-switch-tag
+                #:git-clone)
   (:import-from #:qlot/color
                 #:color-text
                 #:*enable-color*)
@@ -280,7 +285,7 @@ exec /bin/sh \"$CURRENT/../~A\" \"$@\"
       (unwind-protect
            (let* ((sources-non-local
                     (remove-if (lambda (source)
-                                 (typep source 'source-local))
+                                 (typep source '(or source-local source-asdf)))
                                sources))
                   (sources-to-install
                     (with-quicklisp-home qlhome
@@ -377,6 +382,29 @@ exec /bin/sh \"$CURRENT/../~A\" \"$@\"
               (message "Removing dist ~S." (name dist))
               (uninstall dist))))))
 
+    ;; ASDF
+    (let ((asdf-source (find-if (lambda (source)
+                                  (typep source 'source-asdf))
+                                sources))
+          (asdf-dir (merge-pathnames #P"local-projects/asdf/" qlhome)))
+      (cond
+        (asdf-source
+         (cond
+           ((uiop:directory-exists-p asdf-dir)
+            ;; Tag switch
+            (git-switch-tag asdf-dir (source-version asdf-source)))
+           (t
+            (message "Downloading ASDF to '~A'." asdf-dir)
+            ;; Clone
+            (git-clone (source-asdf-remote-url asdf-source)
+                       asdf-dir
+                       :checkout-to (source-version asdf-source)
+                       :recursive nil))))
+        (t
+         (when (uiop:directory-exists-p asdf-dir)
+           (message "Removing ASDF at '~A'." asdf-dir)
+           (uiop:delete-directory-tree asdf-dir :validate t :if-does-not-exist :ignore)))))
+
     (with-open-file (out (merge-pathnames #P"source-registry.conf" qlhome)
                          :direction :output
                          :if-does-not-exist :create

src/source.lisp

@@ -6,4 +6,5 @@
                  #:qlot/source/github
                  #:qlot/source/dist
                  #:qlot/source/ultralisp
-                 #:qlot/source/local))
+                 #:qlot/source/local
+                 #:qlot/source/asdf))

src/source/asdf.lisp

@@ -0,0 +1,28 @@
+(defpackage #:qlot/source/asdf
+  (:use #:cl
+        #:qlot/source/base)
+  (:export #:source-asdf
+           #:source-asdf-remote-url))
+(in-package #:qlot/source/asdf)
+
+(defclass source-asdf (source)
+  ((remote-url :initform "https://gitlab.common-lisp.net/asdf/asdf.git"
+               :accessor source-asdf-remote-url))
+  (:default-initargs
+   :project-name "asdf"))
+
+(defmethod usage-of-source ((source (eql :asdf)))
+  "asdf <version>")
+
+(defmethod make-source ((source (eql :asdf)) &rest initargs)
+  (destructuring-bind (version &rest args) initargs
+    (check-type version string)
+    (apply #'make-instance 'source-asdf
+           :version version
+           args)))
+
+(defmethod source= ((source1 source-asdf) (source2 source-asdf))
+  (and (string= (source-asdf-remote-url source1)
+                (source-asdf-remote-url source2))
+       (string= (source-version source1)
+                (source-version source2))))

src/utils/git.lisp

@@ -7,12 +7,28 @@
   (:import-from #:qlot/utils
                 #:split-with
                 #:starts-with)
-  (:export #:git-clone
+  (:export #:git-switch-tag
+           #:git-clone
            #:create-git-tarball
            #:git-ref))
 (in-package #:qlot/utils/git)
 
-(defun git-clone (remote-url destination &key checkout-to ref)
+(defun git-fetch (directory &rest args)
+  (safety-shell-command "git" `("-C" ,(uiop:native-namestring directory)
+                                "fetch" "--quiet" ,@args))
+  (values))
+
+(defun git-checkout (directory ref)
+  (safety-shell-command "git" `("-C" ,(uiop:native-namestring directory)
+                                "checkout" ,ref "--quiet"))
+  (values))
+
+(defun git-switch-tag (directory tag)
+  (git-fetch directory "origin" (format nil "refs/tags/~A:refs/tags/~:*~A" tag) "--no-tags")
+  (git-checkout directory tag)
+  (values))
+
+(defun git-clone (remote-url destination &key checkout-to ref (recursive t))
   (let ((shallow (not ref)))
     (tagbody git-cloning
       (when (uiop:directory-exists-p destination)
@@ -38,7 +54,8 @@
                                            `("--branch" ,checkout-to))
                                     ,@(and shallow
                                            '("--depth" "1"))
-                                    "--recursive"
+                                    ,@(and recursive
+                                           '("--recursive"))
                                     "--quiet"
                                     "--config" "core.eol=lf"
                                     "--config" "core.autocrlf=input"
@@ -50,10 +67,8 @@
           (go git-cloning)))))
 
   (when ref
-    (safety-shell-command "git" `("-C" ,(uiop:native-namestring destination)
-                                  "fetch" "--quiet"))
-    (safety-shell-command "git" `("-C" ,(uiop:native-namestring destination)
-                                  "checkout" ,ref "--quiet"))))
+    (git-fetch destination)
+    (git-checkout destination ref)))
 
 (defun create-git-tarball (project-directory destination ref)
   (check-type project-directory pathname)