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.

7 files changed, 1011 insertions, 154 deletions

diff --git a/pkgs/development/lisp-modules/quicklisp-to-nix/nix-package.emb b/pkgs/development/lisp-modules/quicklisp-to-nix/nix-package.emb
index baedbd1553a..ac3387d7b6d 100644
--- a/pkgs/development/lisp-modules/quicklisp-to-nix/nix-package.emb
+++ b/pkgs/development/lisp-modules/quicklisp-to-nix/nix-package.emb
@@ -1,9 +1,9 @@
 args @ { fetchurl, ... }:
 rec {
   baseName = ''<% @var filename %>'';
-  version = ''<% @var version %>'';<% @if testname %>
+  version = ''<% @var version %>'';<% @if parasites %>
 
-  testSystems = ["<% @var testname %>"];<% @endif %>
+  parasites = [<% (dolist (p (getf env :parasites)) (format t " \"~A\"" p)) %> ];<% @endif %>
 
   description = ''<% @var description %>'';
 
@@ -13,23 +13,10 @@ rec {
     url = ''<% @var url %>'';
     sha256 = ''<% @var sha256 %>'';
   };
-    
+
   packageName = "<% @var name %>";
 
-  overrides = x: {
-    postInstall = ''
-      find "$out/lib/common-lisp/" -name '*.asd' | grep -iv '/<% @var name %>[.]asd${"$"}' |
-        while read f; do
-          env -i \
-          NIX_LISP="$NIX_LISP" \
-          NIX_LISP_PRELAUNCH_HOOK="nix_lisp_run_single_form '(progn
-            (asdf:load-system :$(basename "$f" .asd))
-            (asdf:perform (quote asdf:compile-bundle-op) :$(basename "$f" .asd))
-            (ignore-errors (asdf:perform (quote asdf:deliver-asd-op) :$(basename "$f" .asd)))
-            )'" \
-            "$out"/bin/*-lisp-launcher.sh ||
-          mv "$f"{,.sibling}; done || true
-    '';
-  };
+  asdFilesToKeep = ["<% @var name %>.asd"];
+  overrides = x: x;
 }
 /* <%= cl-emb-intern::topenv %> */
diff --git a/pkgs/development/lisp-modules/quicklisp-to-nix/parasitic-invocation.emb b/pkgs/development/lisp-modules/quicklisp-to-nix/parasitic-invocation.emb
new file mode 100644
index 00000000000..bdee1c6dcf1
--- /dev/null
+++ b/pkgs/development/lisp-modules/quicklisp-to-nix/parasitic-invocation.emb
@@ -0,0 +1 @@
+  "<% @var filename %>" = quicklisp-to-nix-packages."<% @var host-filename %>";
diff --git a/pkgs/development/lisp-modules/quicklisp-to-nix/ql-to-nix.lisp b/pkgs/development/lisp-modules/quicklisp-to-nix/ql-to-nix.lisp
index f408ceeb3f5..790cd17b2fc 100644
--- a/pkgs/development/lisp-modules/quicklisp-to-nix/ql-to-nix.lisp
+++ b/pkgs/development/lisp-modules/quicklisp-to-nix/ql-to-nix.lisp
@@ -1,137 +1,212 @@
-; QuickLisp-to-Nix export
-; Requires QuickLisp to be loaded
-; Installs the QuickLisp version of all the packages processed (in the
-; QuickLisp instance it uses)
+(unless (find-package :ql-to-nix-util)
+  (load "util.lisp"))
+(unless (find-package :ql-to-nix-quicklisp-bootstrap)
+  (load "quicklisp-bootstrap.lisp"))
+(defpackage :ql-to-nix
+  (:use :common-lisp :ql-to-nix-util :ql-to-nix-quicklisp-bootstrap))
+(in-package :ql-to-nix)
 
-(ql:quickload :cl-emb)
-(ql:quickload :external-program)
-(ql:quickload :cl-ppcre)
-(ql:quickload :alexandria)
-(ql:quickload :md5)
+;; We're going to pull in our dependencies at image dumping time in an
+;; isolated quicklisp installation.  Unfortunately, that means that we
+;; can't yet access the symbols for our dependencies.  We can probably
+;; do better (by, say, loading these dependencies before this file),
+;; but...
 
-(defvar testnames (make-hash-table :test 'equal))
+(defvar *required-systems* nil)
 
-(defun nix-prefetch-url (url)
-  (let*
-    ((stdout nil)
-     (stderr nil))
-    (setf
-      stdout
-      (with-output-to-string (so)
-        (setf
-          stderr
-          (with-output-to-string (se)
-            (external-program:run
-              "nix-prefetch-url"
-              (list url)
-              :search t :output so :error se)))))
-    (let*
-      ((path-line (first (last (cl-ppcre:split (format nil "~%") stderr))))
-       (path (cl-ppcre:regex-replace-all "path is .(.*)." path-line "\\1")))
-      (list
-        :sha256 (first (cl-ppcre:split (format nil "~%") stdout))
-        :path path
-        :md5 (string-downcase
-               (format nil "~{~16,2,'0r~}"
-                       (map 'list 'identity (md5:md5sum-file path))))))))
+(push :cl-emb *required-systems*)
+(wrap :cl-emb register-emb)
+(wrap :cl-emb execute-emb)
+
+(push :external-program *required-systems*)
+(wrap :external-program run)
+
+(push :cl-ppcre *required-systems*)
+(wrap :cl-ppcre split)
+(wrap :cl-ppcre regex-replace-all)
+(wrap :cl-ppcre scan)
+
+(push :alexandria *required-systems*)
+(wrap :alexandria read-file-into-string)
+(wrap :alexandria write-string-into-file)
+
+(push :md5 *required-systems*)
+(wrap :md5 md5sum-file)
+
+(wrap :ql-dist find-system)
+(wrap :ql-dist release)
+(wrap :ql-dist provided-systems)
+(wrap :ql-dist archive-url)
+(wrap :ql-dist local-archive-file)
+(wrap :ql-dist ensure-local-archive-file)
+(wrap :ql-dist archive-md5)
+(wrap :ql-dist name)
+(wrap :ql-dist short-description)
 
 (defun escape-filename (s)
   (format 
-    nil "~a~{~a~}"
-    (if (cl-ppcre:scan "^[a-zA-Z_]" s) "" "_")
-    (loop
+   nil "~a~{~a~}"
+   (if (scan "^[a-zA-Z_]" s) "" "_")
+   (loop
       for x in (map 'list 'identity s)
       collect
-      (case x
-        (#\/ "_slash_")
-        (#\\ "_backslash_")
-        (#\_ "__")
-        (#\. "_dot_")
-        (t x)))))
-
-(defun system-depends-on (system-name)
-  (labels
-      ((decode (name)
-         (typecase name
-           (string
-            name)
-           (cons
-            (ecase (car name)
-              (:version (second name)))))))
-    (let* ((asdf-dependencies (asdf:system-depends-on (asdf:find-system system-name)))
-           (decoded-asdf-dependencies (mapcar #'decode asdf-dependencies))
-           (clean-asdf-dependencies (remove-if-not 'ql-dist:find-system decoded-asdf-dependencies))
-           (ql-dependencies (ql-dist:required-systems (ql-dist:find-system system-name)))
-           (all-dependencies (concatenate 'list clean-asdf-dependencies ql-dependencies))
-           (sorted-dependencies (sort all-dependencies #'string<))
-           (unique-dependencies (remove-duplicates sorted-dependencies :test #'equal)))
-      unique-dependencies)))
+        (case x
+          (#\/ "_slash_")
+          (#\\ "_backslash_")
+          (#\_ "__")
+          (#\. "_dot_")
+          (t x)))))
+
+(defvar *system-info-bin*
+  (let* ((path (uiop:getenv "system-info"))
+         (path-dir (if (equal #\/ (aref path (1- (length path))))
+                       path
+                       (concatenate 'string path "/")))
+         (pathname (parse-namestring path-dir)))
+    (merge-pathnames #P"bin/quicklisp-to-nix-system-info" pathname))
+  "The path to the quicklisp-to-nix-system-info binary.")
+
+(defvar *cache-dir* nil
+  "The folder where fasls will be cached.")
+
+(defun raw-system-info (system-name)
+  "Run quicklisp-to-nix-system-info on the given system and return the
+form produced by the program."
+  (when *cache-dir*
+    (let ((command `(,*system-info-bin* "--cacheDir" ,(namestring *cache-dir*) ,system-name)))
+      (handler-case
+          (return-from raw-system-info
+            (read (make-string-input-stream (uiop:run-program command :output :string))))
+        (error (e)
+          ;; Some systems don't like the funky caching that we're
+          ;; doing.  That's okay.  Let's try it uncached before we
+          ;; give up.
+          (warn "Unable to use cache for system ~A.~%~A" system-name e)))))
+  (read (make-string-input-stream (uiop:run-program `(,*system-info-bin* ,system-name) :output :string))))
+
+(defvar *system-data-memoization-path* nil
+  "The path to the folder where fully-resolved system information can
+be cached.
+
+If information for a system is found in this directory, `system-data'
+will use it instead of re-computing the system data.")
+
+(defvar *system-data-in-memory-memoization*
+  (make-hash-table :test #'equalp))
+
+(defun memoized-system-data-path (system)
+  "Return the path to the file that (if it exists) contains
+pre-computed system data."
+  (when *system-data-memoization-path*
+    (merge-pathnames (make-pathname :name system :type "txt") *system-data-memoization-path*)))
+
+(defun memoized-system-data (system)
+  "Attempts to locate memoized system data in the path specified by
+`*system-data-memoization-path*'."
+  (multiple-value-bind (value found) (gethash system *system-data-in-memory-memoization*)
+    (when found
+      (return-from memoized-system-data (values value found))))
+  (let ((path (memoized-system-data-path system)))
+    (unless path
+      (return-from memoized-system-data (values nil nil)))
+    (with-open-file (s path :if-does-not-exist nil :direction :input)
+      (unless s
+        (return-from memoized-system-data (values nil nil)))
+      (return-from memoized-system-data (values (read s) t)))))
+
+(defun set-memoized-system-data (system data)
+  "Store system data in the path specified by
+`*system-data-memoization-path*'."
+  (setf (gethash system *system-data-in-memory-memoization*) data)
+  (let ((path (memoized-system-data-path system)))
+    (unless path
+      (return-from set-memoized-system-data data))
+    (with-open-file (s path :direction :output :if-exists :supersede)
+      (format s "~W" data)))
+  data)
 
 (defun system-data (system)
-  (let*
-    ((asdf-system
-       (or
-         (ignore-errors (asdf:find-system system))
-         (progn
-           (ql:quickload system)
-           (asdf:find-system system))))
-     (ql-system (ql-dist:find-system system))
-     (ql-release (ql-dist:release ql-system))
-     (ql-sibling-systems (ql-dist:provided-systems ql-release))
-     (url (ql-dist:archive-url ql-release))
-     (local-archive (ql-dist:local-archive-file ql-release))
-     (local-url (format nil "file://~a" (pathname local-archive)))
-     (archive-data
-       (progn
-         (ql-dist:ensure-local-archive-file ql-release)
-         (nix-prefetch-url local-url)))
-     (ideal-md5 (ql-dist:archive-md5 ql-release))
-     (file-md5 (getf archive-data :md5))
-     (raw-dependencies (system-depends-on system))
-     (name (string-downcase (format nil "~a" system)))
-     (ql-sibling-names
-       (remove name (mapcar 'ql-dist:name ql-sibling-systems)
-               :test 'equal))
-     (dependencies
-       (set-difference
-         (remove-duplicates
-           (remove-if-not 'ql-dist:find-system raw-dependencies)
-           :test 'equal)
-         ql-sibling-names
-         :test 'equal))
-     (deps (mapcar (lambda (x) (list :name x :filename (escape-filename x)))
-                   dependencies))
-     (description (asdf:system-description asdf-system))
-     (release-name (ql-dist:short-description ql-release))
-     (version (cl-ppcre:regex-replace-all
-                (format nil "~a-" name) release-name "")))
-    (assert (equal ideal-md5 file-md5))
-  (list
-    :system system
-    :description description
-    :sha256 (getf archive-data :sha256)
-    :url url
-    :md5 file-md5
-    :name name
-    :testname (gethash name testnames)
-    :filename (escape-filename name)
-    :deps deps
-    :dependencies dependencies
-    :version version
-    :siblings ql-sibling-names)))
-
-(defmacro this-file ()
-  (or *compile-file-truename*
-      *load-truename*))
+  "Examine a quicklisp system name and figure out everything that is
+required to produce a nix package.
+
+This function stores results for memoization purposes in files within
+`*system-data-memoization-path*'."
+  (multiple-value-bind (value found) (memoized-system-data system)
+    (when found
+      (return-from system-data value)))
+  (format t "Examining system ~A~%" system)
+  (let* ((system-info (raw-system-info system))
+         (host (getf system-info :host))
+         (host-name (getf system-info :host-name))
+         (name (getf system-info :name)))
+    (when host
+      (return-from system-data
+        (set-memoized-system-data
+         system
+         (list
+          :system (getf system-info :system)
+          :host host
+          :filename (escape-filename name)
+          :host-filename (escape-filename host-name)))))
+
+    (let* ((url (getf system-info :url))
+           (sha256 (getf system-info :sha256))
+           (archive-data (nix-prefetch-url url :expected-sha256 sha256))
+           (archive-path (getf archive-data :path))
+           (archive-md5 (string-downcase
+                         (format nil "~{~16,2,'0r~}"
+                                 (map 'list 'identity (md5sum-file archive-path)))))
+           (stated-md5 (getf system-info :md5))
+           (dependencies (getf system-info :dependencies))
+           (deps (mapcar (lambda (x) (list :name x :filename (escape-filename x)))
+                         dependencies))
+           (description (getf system-info :description))
+           (siblings (getf system-info :siblings))
+           (release-name (getf system-info :release-name))
+           (parasites (getf system-info :parasites))
+           (version (regex-replace-all
+                     (format nil "~a-" name) release-name "")))
+      (assert (equal archive-md5 stated-md5))
+      (set-memoized-system-data
+       system
+       (list
+        :system system
+        :description description
+        :sha256 sha256
+        :url url
+        :md5 stated-md5
+        :name name
+        :filename (escape-filename name)
+        :deps deps
+        :dependencies dependencies
+        :version version
+        :siblings siblings
+        :parasites parasites)))))
+
+(defun parasitic-p (data)
+  (getf data :host))
+
+(defvar *loaded-from* (or *compile-file-truename* *load-truename*)
+  "Where this source file is located.")
+
+(defun this-file ()
+  "Where this source file is located or an error."
+  (or *loaded-from* (error "Not sure where this file is located!")))
 
 (defun nix-expression (system)
-  (cl-emb:execute-emb
-    (merge-pathnames #p"nix-package.emb" (this-file))
+  (execute-emb
+    "nix-package"
     :env (system-data system)))
+
 (defun nix-invocation (system)
-  (cl-emb:execute-emb
-    (merge-pathnames #p"invocation.emb" (this-file))
-    :env (system-data system)))
+  (let ((data (system-data system)))
+    (if (parasitic-p data)
+        (execute-emb
+         "parasitic-invocation"
+         :env data)
+        (execute-emb
+         "invocation"
+         :env data))))
 
 (defun systems-closure (systems)
   (let*
@@ -153,29 +228,97 @@
       finally (return res))))
 
 (defun ql-to-nix (target-directory)
-  (load (format nil "~a/quicklisp-to-nix-overrides.lisp" target-directory))
   (let*
     ((systems
-       (cl-ppcre:split
+       (split
          (format nil "~%")
-         (alexandria:read-file-into-string
-           (format nil "~a/quicklisp-to-nix-systems.txt" target-directory))))
+         (read-file-into-string
+          (format nil "~a/quicklisp-to-nix-systems.txt" target-directory))))
      (closure (systems-closure systems))
      (invocations
        (loop for s in closure
              collect (list :code (nix-invocation s)))))
     (loop
       for s in closure
-      do (alexandria:write-string-into-file
-           (nix-expression s)
-           (format nil "~a/quicklisp-to-nix-output/~a.nix"
-                   target-directory (escape-filename s))
-           :if-exists :supersede))
-    (alexandria:write-string-into-file
-      (cl-emb:execute-emb
-        (merge-pathnames
-          #p"top-package.emb"
-          (this-file))
+       do (unless (parasitic-p (system-data s))
+            (write-string-into-file
+             (nix-expression s)
+             (format nil "~a/quicklisp-to-nix-output/~a.nix"
+                     target-directory (escape-filename s))
+             :if-exists :supersede)))
+    (write-string-into-file
+      (execute-emb
+        "top-package"
         :env (list :invocations invocations))
       (format nil "~a/quicklisp-to-nix.nix" target-directory)
       :if-exists :supersede)))
+
+(defun print-usage-and-quit ()
+  "Does what it says on the tin."
+  (format *error-output* "Usage:
+    ~A [--help] [--cacheSystemInfoDir <path>] <work-dir>
+Arguments:
+    --cacheSystemInfoDir Store computed system info in the given directory
+    --help Print usage and exit
+    <work-dir> Path to directory with quicklisp-to-nix-systems.txt
+" (uiop:argv0))
+  (uiop:quit 2))
+
+(defun main ()
+  "Make it go"
+  (let ((argv (uiop:command-line-arguments))
+        work-directory
+        cache-system-info-directory
+        cache-fasl-directory)
+    (loop :while argv :for arg = (pop argv) :do
+       (cond
+         ((equal arg "--cacheSystemInfoDir")
+          (unless argv
+            (format *error-output* "--cacheSystemInfoDir requires an argument~%")
+            (print-usage-and-quit))
+          (setf cache-system-info-directory (pop argv)))
+
+         ((equal arg "--cacheFaslDir")
+          (unless argv
+            (format *error-output* "--cacheFaslDir requires an argument~%")
+            (print-usage-and-quit))
+          (setf cache-fasl-directory (pop argv)))
+
+         ((equal arg "--help")
+          (print-usage-and-quit))
+
+         (t
+          (when argv
+            (format *error-output* "Only one positional argument allowed~%")
+            (print-usage-and-quit))
+          (setf work-directory arg))))
+
+    (when cache-system-info-directory
+      (setf cache-system-info-directory (pathname-as-directory (pathname cache-system-info-directory)))
+      (ensure-directories-exist cache-system-info-directory))
+
+    (labels
+        ((make-go (*cache-dir*)
+           (format t "Caching fasl files in ~A~%" *cache-dir*)
+
+           (let ((*system-data-memoization-path* cache-system-info-directory))
+             (ql-to-nix work-directory))))
+      (if cache-fasl-directory
+          (make-go (truename (pathname-as-directory (parse-namestring (ensure-directories-exist cache-fasl-directory)))))
+          (with-temporary-directory (*cache-dir*)
+            (make-go *cache-dir*))))))
+
+(defun dump-image ()
+  "Make an executable"
+  (with-quicklisp (dir) ()
+    (declare (ignore dir))
+    (dolist (system *required-systems*)
+      (funcall (sym :ql :quickload) system)))
+  (register-emb "nix-package" (merge-pathnames #p"nix-package.emb" (this-file)))
+  (register-emb "invocation" (merge-pathnames #p"invocation.emb" (this-file)))
+  (register-emb "parasitic-invocation" (merge-pathnames #p"parasitic-invocation.emb" (this-file)))
+  (register-emb "top-package" (merge-pathnames #p"top-package.emb" (this-file)))
+  (setf uiop:*image-entry-point* #'main)
+  (setf uiop:*lisp-interaction* nil)
+  (setf *loaded-from* nil) ;; Break the link to our source
+  (uiop:dump-image "quicklisp-to-nix" :executable t))
diff --git a/pkgs/development/lisp-modules/quicklisp-to-nix/quicklisp-bootstrap.lisp b/pkgs/development/lisp-modules/quicklisp-to-nix/quicklisp-bootstrap.lisp
new file mode 100644
index 00000000000..1c4a682007f
--- /dev/null
+++ b/pkgs/development/lisp-modules/quicklisp-to-nix/quicklisp-bootstrap.lisp
@@ -0,0 +1,76 @@
+(unless (find-package :ql-to-nix-util)
+  (load "ql-to-nix-util.lisp"))
+(defpackage :ql-to-nix-quicklisp-bootstrap
+  (:use :common-lisp :ql-to-nix-util)
+  (:export #:with-quicklisp)
+  (:documentation
+   "This package provides a way to create a temporary quicklisp installation."))
+(in-package :ql-to-nix-quicklisp-bootstrap)
+
+(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!
+
+(defvar *quicklisp*
+  (namestring (pathname-as-directory (uiop:getenv "quicklisp")))
+  "The path to the nix quicklisp package.")
+
+(defun prepare-quicklisp-dir (target-dir quicklisp-prototype-dir)
+  "Install quicklisp into the specified `target-dir'.
+
+`quicklisp-prototype-dir' should be the path to the quicklisp nix
+package."
+  (ensure-directories-exist target-dir)
+  (dolist (subdir '(#P"dists/quicklisp/" #P"tmp/" #P"local-projects/" #P"quicklisp/"))
+    (ensure-directories-exist (merge-pathnames subdir target-dir)))
+  (with-open-file (s (merge-pathnames #P"dists/quicklisp/enabled.txt" target-dir) :direction :output :if-exists :supersede)
+    (format s "1~%"))
+  (uiop:copy-file
+   (merge-pathnames #P"lib/common-lisp/quicklisp/quicklisp-distinfo.txt" quicklisp-prototype-dir)
+   (merge-pathnames #P"dists/quicklisp/distinfo.txt" target-dir))
+  (uiop:copy-file
+   (merge-pathnames #P"lib/common-lisp/quicklisp/asdf.lisp" quicklisp-prototype-dir)
+   (merge-pathnames #P"asdf.lisp" target-dir))
+  (uiop:copy-file
+   (merge-pathnames #P"lib/common-lisp/quicklisp/setup.lisp" quicklisp-prototype-dir)
+   (merge-pathnames #P"setup.lisp" target-dir))
+  (copy-directory-tree
+   (merge-pathnames #P"lib/common-lisp/quicklisp/quicklisp/" quicklisp-prototype-dir)
+   (merge-pathnames #P"quicklisp/" target-dir)))
+
+(defun call-with-quicklisp (function &key (target-dir :temp) (cache-dir :temp))
+  "Invoke the given function with the path to a quicklisp installation.
+
+Quicklisp will be loaded before the function is called.  `target-dir'
+can either be a pathname for the place where quicklisp should be
+installed or `:temp' to request installation in a temporary directory.
+`cache-dir' can either be a pathname for a place to store fasls or
+`:temp' to request caching in a temporary directory."
+  (when (find-package :ql)
+    (error "Already loaded quicklisp in this process"))
+  (labels
+      ((make-ql (ql-dir)
+         (prepare-quicklisp-dir ql-dir *quicklisp*)
+         (with-temporary-asdf-cache (ql-dir)
+           (load (merge-pathnames #P"setup.lisp" ql-dir))
+           (if (eq :temp cache-dir)
+               (funcall function ql-dir)
+               (with-asdf-cache (ql-dir cache-dir)
+                 (funcall function ql-dir))))))
+    (if (eq :temp target-dir)
+        (with-temporary-directory (dir)
+          (make-ql dir))
+        (make-ql target-dir))))
+
+(defmacro with-quicklisp ((quicklisp-dir) (&key (cache-dir :temp)) &body body)
+  "Install quicklisp in a temporary directory, load it, bind
+`quicklisp-dir' to the path where quicklisp was installed, and then
+evaluate `body'.
+
+`cache-dir' can either be a pathname for a place to store fasls or
+`:temp' to request caching in a temporary directory."
+  `(call-with-quicklisp
+    (lambda (,quicklisp-dir)
+      ,@body)
+    :cache-dir ,cache-dir))
diff --git a/pkgs/development/lisp-modules/quicklisp-to-nix/system-info.lisp b/pkgs/development/lisp-modules/quicklisp-to-nix/system-info.lisp
new file mode 100644
index 00000000000..3a87626df1b
--- /dev/null
+++ b/pkgs/development/lisp-modules/quicklisp-to-nix/system-info.lisp
@@ -0,0 +1,473 @@
+(unless (find-package :ql-to-nix-util)
+  (load "util.lisp"))
+(unless (find-package :ql-to-nix-quicklisp-bootstrap)
+  (load "quicklisp-bootstrap.lisp"))
+(defpackage :ql-to-nix-system-info
+  (:use :common-lisp :ql-to-nix-quicklisp-bootstrap :ql-to-nix-util)
+  (:export #:dump-image))
+(in-package :ql-to-nix-system-info)
+
+(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!
+
+;; We can't load quicklisp until runtime (at which point we'll create
+;; an isolated quicklisp installation).  These wrapper functions are
+;; nicer than funcalling intern'd symbols every time we want to talk
+;; to quicklisp.
+(wrap :ql apply-load-strategy)
+(wrap :ql compute-load-strategy)
+(wrap :ql show-load-strategy)
+(wrap :ql quicklisp-systems)
+(wrap :ql ensure-installed)
+(wrap :ql quicklisp-releases)
+(wrap :ql-dist archive-md5)
+(wrap :ql-dist archive-url)
+(wrap :ql-dist ensure-local-archive-file)
+(wrap :ql-dist find-system)
+(wrap :ql-dist local-archive-file)
+(wrap :ql-dist name)
+(wrap :ql-dist provided-systems)
+(wrap :ql-dist release)
+(wrap :ql-dist short-description)
+(wrap :ql-dist system-file-name)
+(wrap :ql-impl-util call-with-quiet-compilation)
+
+(defvar *version* (uiop:getenv "version")
+  "The version number of this program")
+
+(defvar *main-system* nil
+  "The name of the system we're trying to extract info from.")
+
+(defvar *found-parasites* (make-hash-table :test #'equalp)
+  "Names of systems which have been identified as parasites.
+
+A system is parasitic if its name doesn't match the name of the file
+it is defined in.  So, for example, if foo and foo-bar are both
+defined in a file named foo.asd, foo would be the host system and
+foo-bar would be a parasitic system.
+
+Parasitic systems are not generally loaded without loading the host
+system first.
+
+Keys are system names.  Values are unspecified.")
+
+(defvar *found-dependencies* (make-hash-table :test #'equalp)
+  "Hash table containing the set of dependencies discovered while installing a system.
+
+Keys are system names.  Values are unspecified.")
+
+(defun decode-asdf-dependency (name)
+  "Translates an asdf system dependency description into a system name.
+
+For example, translates (:version :foo \"1.0\") into \"foo\"."
+  (etypecase name
+    (symbol
+     (setf name (symbol-name name)))
+    (string)
+    (cons
+     (ecase (first name)
+       (:version
+        (warn "Discarding version information ~A" name)
+        ;; There's nothing we can do about this.  If the version we
+        ;; have around is good enough, then we're golden.  If it isn't
+        ;; good enough, then we'll error out and let a human figure it
+        ;; out.
+        (setf name (second name))
+        (return-from decode-asdf-dependency
+          (decode-asdf-dependency name)))
+
+       (:feature
+        (if (find (second name) *features*)
+            (return-from decode-asdf-dependency
+              (decode-asdf-dependency (third name)))
+            (progn
+              (warn "Dropping dependency due to missing feature: ~A" name)
+              (return-from decode-asdf-dependency nil))))
+
+       (:require
+        ;; This probably isn't a dependency we can satisfy using
+        ;; quicklisp, but we might as well try anyway.
+        (return-from decode-asdf-dependency
+          (decode-asdf-dependency (second name)))))))
+  (string-downcase name))
+
+(defun found-new-parasite (system-name)
+  "Record that the given system has been identified as a parasite."
+  (setf system-name (decode-asdf-dependency system-name))
+  (setf (gethash system-name *found-parasites*) t)
+  (when (nth-value 1 (gethash system-name *found-dependencies*))
+    (error "Found dependency on parasite")))
+
+(defun known-parasite-p (system-name)
+  "Have we previously identified this system as a parasite?"
+  (nth-value 1 (gethash system-name *found-parasites*)))
+
+(defun found-parasites ()
+  "Return a vector containing all identified parasites."
+  (let ((systems (make-array (hash-table-size *found-parasites*) :fill-pointer 0)))
+    (loop :for system :being :the :hash-keys :of *found-parasites* :do
+       (vector-push system systems))
+    systems))
+
+(defvar *track-dependencies* nil
+  "When this variable is nil, found-new-dependency will not record
+depdendencies.")
+
+(defun parasitic-relationship-p (potential-host potential-parasite)
+  "Returns t if potential-host and potential-parasite have a parasitic relationship.
+
+See `*found-parasites*'."
+  (let ((host-ql-system (find-system potential-host))
+        (parasite-ql-system (find-system potential-parasite)))
+    (and host-ql-system parasite-ql-system
+         (not (equal (name host-ql-system)
+                     (name parasite-ql-system)))
+         (equal (system-file-name host-ql-system)
+                (system-file-name parasite-ql-system)))))
+
+(defun found-new-dependency (name)
+  "Record that the given system has been identified as a dependency.
+
+The named system may not be recorded as a dependency.  It may be left
+out for any number of reasons.  For example, if `*track-dependencies*'
+is nil then this function does nothing.  If the named system isn't a
+quicklisp system, this function does nothing."
+  (setf name (decode-asdf-dependency name))
+  (unless name
+    (return-from found-new-dependency))
+  (unless *track-dependencies*
+    (return-from found-new-dependency))
+  (when (known-parasite-p name)
+    (return-from found-new-dependency))
+  (when (parasitic-relationship-p *main-system* name)
+    (found-new-parasite name)
+    (return-from found-new-dependency))
+  (unless (find-system name)
+    (return-from found-new-dependency))
+  (setf (gethash name *found-dependencies*) t))
+
+(defun forget-dependency (name)
+  "Whoops.  Did I say that was a dependency?  My bad.
+
+Be very careful using this function!  You can remove a system from the
+dependency list, but you can't remove other effects associated with
+this system.  For example, transitive dependencies might still be in
+the dependency list."
+  (setf name (decode-asdf-dependency name))
+  (remhash name *found-dependencies*))
+
+(defun found-dependencies ()
+  "Return a vector containing all identified dependencies."
+  (let ((systems (make-array (hash-table-size *found-dependencies*) :fill-pointer 0)))
+    (loop :for system :being :the :hash-keys :of *found-dependencies* :do
+       (vector-push system systems))
+    systems))
+
+(defun host-system (system-name)
+  "If the given system is a parasite, return the name of the system that is its host.
+
+See `*found-parasites*'."
+  (let* ((system (find-system system-name))
+         (host-file (system-file-name system)))
+    (unless (equalp host-file system-name)
+      host-file)))
+
+(defun get-loaded (system)
+  "Try to load the named system using quicklisp and record any
+dependencies quicklisp is aware of.
+
+Unlike `our-quickload', this function doesn't attempt to install
+missing dependencies."
+  ;; Let's get this party started!
+  (let* ((strategy (compute-load-strategy system))
+         (ql-systems (quicklisp-systems strategy)))
+    (dolist (dep ql-systems)
+      (found-new-dependency (name dep)))
+    (show-load-strategy strategy)
+    (labels
+        ((make-go ()
+           (apply-load-strategy strategy)))
+      (call-with-quiet-compilation #'make-go)
+      (let ((asdf-system (asdf:find-system system)))
+        ;; If ASDF says that it needed a system, then we should
+        ;; probably track that.
+        (dolist (asdf-dep (asdf:component-sideway-dependencies asdf-system))
+          (found-new-dependency asdf-dep))
+        (dolist (asdf-dep (asdf:system-defsystem-depends-on asdf-system))
+          (found-new-dependency asdf-dep))))))
+
+(defun our-quickload (system)
+  "Attempt to install a package like quicklisp would, but record any
+dependencies that are detected during the install."
+  (setf system (string-downcase system))
+  ;; Load it quickly, but do it OUR way.  Turns out our way is very
+  ;; similar to the quicklisp way...
+  (let ((already-tried (make-hash-table :test #'equalp))) ;; Case insensitive
+    (tagbody
+     retry
+       (handler-case
+           (get-loaded system)
+         (asdf/find-component:missing-dependency (e)
+           (let ((required-by (asdf/find-component:missing-required-by e))
+                 (missing (asdf/find-component:missing-requires e)))
+             (unless (typep required-by 'asdf:system)
+               (error e))
+             (when (gethash missing already-tried)
+               (error "Dependency loop? ~A" missing))
+             (setf (gethash missing already-tried) t)
+             (let ((parasitic-p (parasitic-relationship-p *main-system* missing)))
+               (if parasitic-p
+                   (found-new-parasite missing)
+                   (found-new-dependency missing))
+               ;; We always want to track the dependencies of systems
+               ;; that share an asd file with the main system.  The
+               ;; whole asd file should be loadable.  Otherwise, we
+               ;; don't want to include transitive dependencies.
+               (let ((*track-dependencies* parasitic-p))
+                 (our-quickload missing)))
+             (format t "Attempting to load ~A again~%" system)
+             (go retry)))))))
+
+(defvar *blacklisted-parasites*
+  #("hu.dwim.stefil/documentation" ;; This system depends on :hu.dwim.stefil.test, but it should depend on hu.dwim.stefil/test
+    "named-readtables/doc" ;; Dependency cycle between named-readtabes and mgl-pax
+    "symbol-munger-test" ;; Dependency cycle between lisp-unit2 and symbol-munger
+    "cl-postgres-simple-date-tests" ;; Dependency cycle between cl-postgres and simple-date
+    "cl-containers/with-variates") ;; Symbol conflict between cl-variates:next-element, metabang.utilities:next-element
+  "A vector of systems that shouldn't be loaded by `quickload-parasitic-systems'.
+
+These systems are known to be troublemakers.  In some sense, all
+parasites are troublemakers (you shouldn't define parasitic systems!).
+However, these systems prevent us from generating nix packages and are
+thus doubly evil.")
+
+(defvar *blacklisted-parasites-table*
+  (let ((ht (make-hash-table :test #'equalp)))
+    (loop :for system :across *blacklisted-parasites* :do
+       (setf (gethash system ht) t))
+    ht)
+  "A hash table where each entry in `*blacklisted-parasites*' is an
+entry in the table.")
+
+(defun blacklisted-parasite-p (system-name)
+  "Returns non-nil if the named system is blacklisted"
+  (nth-value 1 (gethash system-name *blacklisted-parasites-table*)))
+
+(defun quickload-parasitic-systems (system)
+  "Attempt to load all the systems defined in the same asd as the named system.
+
+Blacklisted systems are skipped.  Dependencies of the identified
+parasitic systems will be tracked."
+  (let* ((asdf-system (asdf:find-system system))
+         (source-file (asdf:system-source-file asdf-system)))
+    (cond
+      (source-file
+       (loop :for system-name :being :the :hash-keys :of asdf/find-system:*defined-systems* :do
+          (when (and (parasitic-relationship-p system system-name)
+                     (not (blacklisted-parasite-p system-name)))
+            (found-new-parasite system-name)
+            (let ((*track-dependencies* t))
+              (our-quickload system-name)))))
+      (t
+       (unless (or (equal "uiop" system)
+                   (equal "asdf" system))
+         (warn "No source file for system ~A.  Can't identify parasites." system))))))
+
+(defun determine-dependencies (system)
+  "Load the named system and return a sorted vector containing all the
+quicklisp systems that were loaded to satisfy dependencies.
+
+This function should probably only be called once per process!
+Subsequent calls will miss dependencies identified by earlier calls."
+  (tagbody
+   retry
+     (restart-case
+         (let ((*standard-output* (make-broadcast-stream))
+               (*trace-output* (make-broadcast-stream))
+               (*main-system* system)
+               (*track-dependencies* t))
+           (our-quickload system)
+           (quickload-parasitic-systems system))
+       (try-again ()
+         :report "Start the quickload over again"
+         (go retry))
+       (die ()
+         :report "Just give up and die"
+         (uiop:quit 1))))
+
+  ;; Systems can't depend on themselves!
+  (forget-dependency system)
+  (values))
+
+(defun parasitic-system-data (parasite-system)
+  "Return a plist of information about the given known-parastic system.
+
+Sometimes we are asked to provide information about a system that is
+actually a parasite.  The only correct response is to point them
+toward the host system.  The nix package for the host system should
+have all the dependencies for this parasite already recorded.
+
+The plist is only meant to be consumed by other parts of
+quicklisp-to-nix."
+  (let ((host-system (host-system parasite-system)))
+    (list
+     :system parasite-system
+     :host host-system
+     :name (string-downcase (format nil "~a" parasite-system))
+     :host-name (string-downcase (format nil "~a" host-system)))))
+
+(defun system-data (system)
+  "Produce a plist describing a system.
+
+The plist is only meant to be consumed by other parts of
+quicklisp-to-nix."
+  (when (host-system system)
+    (return-from system-data
+      (parasitic-system-data system)))
+
+  (determine-dependencies system)
+  (let*
+      ((dependencies (sort (found-dependencies) #'string<))
+       (parasites (coerce (sort (found-parasites) #'string<) 'list))
+       (ql-system (find-system system))
+       (ql-release (release ql-system))
+       (ql-sibling-systems (provided-systems ql-release))
+       (url (archive-url ql-release))
+       (local-archive (local-archive-file ql-release))
+       (local-url (format nil "file://~a" (pathname local-archive)))
+       (archive-data
+        (progn
+          (ensure-local-archive-file ql-release)
+          ;; Stuff this archive into the nix store.  It was almost
+          ;; certainly going to end up there anyway (since it will
+          ;; probably be fetchurl'd for a nix package).  Also, putting
+          ;; it into the store also gives us the SHA we need.
+          (nix-prefetch-url local-url)))
+       (ideal-md5 (archive-md5 ql-release))
+       (raw-dependencies (coerce dependencies 'list))
+       (name (string-downcase (format nil "~a" system)))
+       (ql-sibling-names
+        (remove name (mapcar 'name ql-sibling-systems)
+                :test 'equal))
+       (dependencies raw-dependencies)
+       (description (asdf:system-description (asdf:find-system system)))
+       (release-name (short-description ql-release)))
+    (list
+     :system system
+     :description description
+     :sha256 (getf archive-data :sha256)
+     :url url
+     :md5 ideal-md5
+     :name name
+     :dependencies dependencies
+     :siblings ql-sibling-names
+     :release-name release-name
+     :parasites parasites)))
+
+(defvar *error-escape-valve* *error-output*
+  "When `*error-output*' is rebound to inhibit spew, this stream will
+still produce output.")
+
+(defun print-usage-and-quit ()
+  "Describe how to use this program... and then exit."
+  (format *error-output* "Usage:
+    ~A [--cacheDir <dir>] [--silent] [--debug] [--help|-h] <system-name>
+Arguments:
+    --cacheDir Store (and look for) compiled lisp files in the given directory
+    --verbose Show compilation output
+    --debug Enter the debugger when a fatal error is encountered
+    --help Print usage and exit
+    <system-name> The quicklisp system to examine
+" (or (uiop:argv0) "quicklisp-to-nix-system-info"))
+  (uiop:quit 2))
+
+(defun main ()
+  "Make it go."
+  (let ((argv (uiop:command-line-arguments))
+        cache-dir
+        target-system
+        verbose-p
+        debug-p)
+    (handler-bind
+        ((warning
+          (lambda (w)
+            (format *error-escape-valve* "~A~%" w)))
+         (error
+          (lambda (e)
+            (if debug-p
+                (invoke-debugger e)
+                (progn
+                  (format *error-escape-valve* "~
+Failed to extract system info. Details are below. ~
+Run with --debug and/or --verbose for more info.
+~A~%" e)
+                  (uiop:quit 1))))))
+      (loop :while argv :do
+         (cond
+           ((equal "--cacheDir" (first argv))
+            (pop argv)
+            (unless argv
+              (error "--cacheDir expects an argument"))
+            (setf cache-dir (first argv))
+            (pop argv))
+
+           ((equal "--verbose" (first argv))
+            (setf verbose-p t)
+            (pop argv))
+
+           ((equal "--debug" (first argv))
+            (setf debug-p t)
+            (pop argv))
+
+           ((or (equal "--help" (first argv))
+                (equal "-h" (first argv)))
+            (print-usage-and-quit))
+
+           (t
+            (setf target-system (pop argv))
+            (when argv
+              (error "Can only operate on one system")))))
+
+      (unless target-system
+        (print-usage-and-quit))
+
+      (when cache-dir
+        (setf cache-dir (pathname-as-directory (parse-namestring cache-dir))))
+
+      (with-quicklisp (dir) (:cache-dir (or cache-dir :temp))
+        (declare (ignore dir))
+
+        (let (system-data)
+          (let ((*error-output* (if verbose-p
+                                    *error-output*
+                                    (make-broadcast-stream)))
+                (*standard-output* (if verbose-p
+                                       *standard-output*
+                                       (make-broadcast-stream)))
+                (*trace-output* (if verbose-p
+                                    *trace-output*
+                                    (make-broadcast-stream))))
+            (format *error-output*
+                    "quicklisp-to-nix-system-info ~A~%ASDF ~A~%Quicklisp ~A~%Compiler ~A ~A~%"
+                    *version*
+                    (asdf:asdf-version)
+                    (funcall (intern "CLIENT-VERSION" :ql))
+                    (lisp-implementation-type)
+                    (lisp-implementation-version))
+            (setf system-data (system-data target-system)))
+
+          (cond
+            (system-data
+             (format t "~W~%" system-data)
+             (uiop:quit 0))
+            (t
+             (format *error-output* "Failed to determine system data~%")
+             (uiop:quit 1))))))))
+
+(defun dump-image ()
+  "Make an executable"
+  (setf uiop:*image-entry-point* #'main)
+  (setf uiop:*lisp-interaction* nil)
+  (uiop:dump-image "quicklisp-to-nix-system-info" :executable t))
diff --git a/pkgs/development/lisp-modules/quicklisp-to-nix/top-package.emb b/pkgs/development/lisp-modules/quicklisp-to-nix/top-package.emb
index 95b60df0d01..9ba7a89eb25 100644
--- a/pkgs/development/lisp-modules/quicklisp-to-nix/top-package.emb
+++ b/pkgs/development/lisp-modules/quicklisp-to-nix/top-package.emb
@@ -8,7 +8,6 @@ let quicklisp-to-nix-packages = rec {
 <% @loop invocations %>
 <% @var code %>
 <% @endloop %>
-} // qlAliases {inherit quicklisp-to-nix-packages;};
-qlAliases = import ./quicklisp-to-nix-aliases.nix;
+};
 in
    quicklisp-to-nix-packages
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 00000000000..7b404304273
--- /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)))))