Overhaul quicklisp-to-nix

1. Detect (and automatically handle) parasitic systems.
2. Each nix package has only one asd, and (almost) every parasitic
   package inside it builds.
3. Ensure that parasitic systems are compiled.
4. Remove unnecessary testnames lisp override mechanism (the
   testnae/testSystem is replaced by parasites/buildSystems).
5. Parasitic systems (if included in the system closure) become
   aliases to their host package.
6. Support caching fasl files in a known directory (for faster
   re-generation after modifying quicklisp-to-nix-system-info).
7. Eliminate unnecessary overrides.  We're going to determine ALL
   lisp dependencies correctly.
8. Don't try to "build" lisp packages with make.  lispPackages should
   be about bringing in a lisp library.
9. Eliminate the hand-maintained list of aliases.  Parasites should
   become aliases.  Everything else should be a real package.

1 files changed, 178 insertions, 0 deletions

diff --git a/pkgs/development/lisp-modules/quicklisp-to-nix/util.lisp b/pkgs/development/lisp-modules/quicklisp-to-nix/util.lisp
new file mode 100644
index 000000000000..7b4043042735
--- /dev/null
+++ b/pkgs/development/lisp-modules/quicklisp-to-nix/util.lisp
@@ -0,0 +1,178 @@
+(defpackage :ql-to-nix-util
+  (:use :common-lisp)
+  (:export #:nix-prefetch-url #:wrap #:pathname-as-directory #:copy-directory-tree #:with-temporary-directory #:sym #:with-temporary-asdf-cache #:with-asdf-cache)
+  (:documentation
+   "A collection of useful functions and macros that ql-to-nix will use."))
+(in-package :ql-to-nix-util)
+
+(declaim (optimize (debug 3) (speed 0) (space 0) (compilation-speed 0) (safety 3)))
+
+;; This file cannot have any dependencies beyond quicklisp and asdf.
+;; Otherwise, we'll miss some dependencies!
+
+(defun pathname-as-directory (pathname)
+  "Given a pathname, make it into a path to a directory.
+
+This is sort of like putting a / at the end of the path."
+  (unless (pathname-name pathname)
+    (return-from pathname-as-directory pathname))
+  (let* ((old-dir (pathname-directory pathname))
+         (old-name (pathname-name pathname))
+         (old-type (pathname-type pathname))
+         (last-dir
+          (cond
+            (old-type
+             (format nil "~A.~A" old-name old-type))
+            (t
+             old-name)))
+         (new-dir (if old-dir
+                      (concatenate 'list old-dir (list last-dir))
+                      (list :relative last-dir))))
+
+    (make-pathname :name nil :directory new-dir :type nil :defaults pathname)))
+
+(defvar *nix-prefetch-url-bin*
+  (namestring (merge-pathnames #P"bin/nix-prefetch-url" (pathname-as-directory (uiop:getenv "nix-prefetch-url"))))
+  "The path to the nix-prefetch-url binary")
+
+(defun nix-prefetch-url (url &key expected-sha256)
+  "Invoke the nix-prefetch-url program.
+
+Returns a plist with two keys.
+:sha256 => The sha of the fetched file
+:path => The path to the file in the nix store"
+  (when expected-sha256
+    (setf expected-sha256 (list expected-sha256)))
+  (let* ((stdout
+          (with-output-to-string (so)
+            (uiop:run-program
+             `(,*nix-prefetch-url-bin* "--print-path" ,url ,@expected-sha256)
+             :output so)))
+         (stream (make-string-input-stream stdout)))
+    (list
+     :sha256 (read-line stream)
+     :path (read-line stream))))
+
+(defmacro wrap (package symbol-name)
+  "Create a function which looks up the named symbol at runtime and
+invokes it with the same arguments.
+
+If you can't load a system until runtime, this macro gives you an
+easier way to write
+    (funcall (intern \"SYMBOL-NAME\" :package-name) arg)
+Instead, you can write
+    (wrap :package-name symbol-name)
+    (symbol-name arg)"
+  (let ((args (gensym "ARGS")))
+    `(defun ,symbol-name (&rest ,args)
+       (apply (sym ',package ',symbol-name) ,args))))
+
+(defun copy-directory-tree (src-dir target-dir)
+  "Recursively copy every file in `src-dir' into `target-dir'.
+
+This function traverses symlinks."
+  (when (or (not (pathname-directory target-dir))
+            (pathname-name target-dir))
+    (error "target-dir must be a dir"))
+  (when (or (not (pathname-directory src-dir))
+            (pathname-name src-dir))
+    (error "src-dir must be a dir"))
+  (let ((src-wild (make-pathname :name :wild :type :wild :defaults src-dir)))
+    (dolist (entity (uiop:directory* src-wild))
+      (if (pathname-name entity)
+          (uiop:copy-file entity (make-pathname :type (pathname-type entity) :name (pathname-name entity) :defaults target-dir))
+          (let ((new-target-dir
+                 (make-pathname
+                  :directory (concatenate 'list (pathname-directory target-dir) (last (pathname-directory entity))))))
+            (ensure-directories-exist new-target-dir)
+            (copy-directory-tree entity new-target-dir))))))
+
+(defun call-with-temporary-directory (function)
+  "Create a temporary directory, invoke the given function by passing
+in the pathname for the directory, and then delete the directory."
+  (let* ((dir (uiop:run-program '("mktemp" "-d") :output :line))
+         (parsed (parse-namestring dir))
+         (parsed-as-dir (pathname-as-directory parsed)))
+    (assert (uiop:absolute-pathname-p dir))
+    (unwind-protect
+         (funcall function parsed-as-dir)
+      (uiop:delete-directory-tree
+       parsed-as-dir
+       :validate
+       (lambda (path)
+         (and (uiop:absolute-pathname-p path)
+              (equal (subseq (pathname-directory path) 0 (length (pathname-directory parsed-as-dir)))
+                     (pathname-directory parsed-as-dir))))))))
+
+(defmacro with-temporary-directory ((dir-name) &body body)
+  "See `call-with-temporary-directory'."
+  `(call-with-temporary-directory (lambda (,dir-name) ,@body)))
+
+(defun sym (package sym)
+  "A slightly less picky version of `intern'.
+
+Unlike `intern', the `sym' argument can be a string or a symbol.  If
+it is a symbol, then the `symbol-name' is `intern'ed into the
+specified package.
+
+The arguments are also reversed so that the package comes first."
+  (etypecase sym
+    (symbol (setf sym (symbol-name sym)))
+    (string))
+  (intern sym package))
+
+(defvar *touch-bin*
+  (namestring (merge-pathnames #P"bin/touch" (pathname-as-directory (uiop:getenv "touch"))))
+  "Path to the touch binary.")
+
+(defvar *cache-dir* nil
+  "When asdf cache remapping is in effect (see `with-asdf-cache'),
+this stores the path to the fasl cache directory.")
+(defvar *src-dir* nil
+  "When asdf cache remapping is in effect (see `with-asdf-cache'),
+this stores the path to the source directory.
+
+Only lisp files within the source directory will have their fasls
+cached in the cache directory.")
+
+(defun remap (path prefix)
+  "Implements the cache policy described in `with-asdf-cache'."
+  (declare (ignore prefix))
+  (let* ((ql-dirs (pathname-directory *src-dir*))
+         (ql-dirs-length (length ql-dirs))
+         (path-prefix (subseq (pathname-directory path) 0 ql-dirs-length))
+         (path-postfix (subseq (pathname-directory path) ql-dirs-length)))
+    (unless (equal path-prefix ql-dirs)
+      (return-from remap path))
+    (let ((result (make-pathname :directory (concatenate 'list (pathname-directory *cache-dir*) path-postfix) :defaults path)))
+      (with-open-file (s result :direction :probe :if-does-not-exist nil)
+        (when s
+          (uiop:run-program `(,*touch-bin* ,(namestring result)))))
+      result)))
+
+(defmacro with-temporary-asdf-cache ((src-dir) &body body)
+  "Create a temporary directory, and then use it as the ASDF cache
+directory for source files in `src-dir'.
+
+See `with-asdf-cache'."
+  (let ((tmp-dir (gensym "ORIGINAL-VALUE")))
+    `(with-temporary-directory (,tmp-dir)
+       (with-asdf-cache (,src-dir ,tmp-dir)
+         ,@body))))
+
+(defmacro with-asdf-cache ((src-dir cache-dir) &body body)
+  "When ASDF compiles a lisp file in `src-dir', store the fasl in `cache-dir'."
+  (let ((original-value (gensym "ORIGINAL-VALUE")))
+    `(let ((,original-value asdf:*output-translations-parameter*)
+           (*src-dir* ,src-dir)
+           (*cache-dir* ,cache-dir))
+       (unwind-protect
+            (progn
+              (asdf:initialize-output-translations
+               '(:output-translations
+                 :INHERIT-CONFIGURATION
+                 ;; FIXME: Shouldn't we only be remaping things
+                 ;; actually in the src dir?  Oh well.
+                 (t (:function remap))))
+              ,@body)
+         (asdf:initialize-output-translations ,original-value)))))