uboot: (firmwareOdroidC2/C4) don't invoke patch tool, use patches = [] instead
https://github.com/NixOS/nixpkgs/blob/master/pkgs/stdenv/generic/setup.sh#L948 this can do it nicely. Signed-off-by: Anton Arapov <anton@deadbeef.mx>
This commit is contained in:
Anton Arapov
Alan Daniels
commit
56de2bcd43
30691 changed files with 3076956 additions and 0 deletions
|
|
@ -0,0 +1,7 @@
|
|||
"<% @var filename %>" = buildLispPackage
|
||||
((f: x: (x // (f x)))
|
||||
(qlOverrides."<% @var filename %>" or (x: {}))
|
||||
(import ./quicklisp-to-nix-output/<% @var filename %>.nix {
|
||||
inherit fetchurl;<% @loop deps %>
|
||||
"<% @var filename %>" = quicklisp-to-nix-packages."<% @var filename %>";<% @endloop %>
|
||||
}));
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
/* Generated file. */
|
||||
args @ { fetchurl, ... }:
|
||||
rec {
|
||||
baseName = "<% @var filename %>";
|
||||
version = "<% @var version %>";<% @if parasites %>
|
||||
|
||||
parasites = [<% (dolist (p (getf env :parasites)) (format t " \"~A\"" p)) %> ];<% @endif %>
|
||||
|
||||
description = <%= (format nil "~s" (cl-emb::getf-emb "description")) %>;
|
||||
|
||||
deps = [ <% @loop deps %>args."<% @var filename %>" <% @endloop %>];
|
||||
|
||||
src = fetchurl {
|
||||
url = "<% @var url %>";
|
||||
sha256 = "<% @var sha256 %>";
|
||||
};
|
||||
|
||||
packageName = "<% @var name %>";
|
||||
|
||||
asdFilesToKeep = ["<% @var name %>.asd"];
|
||||
overrides = x: x;
|
||||
}
|
||||
/* <%= cl-emb-intern::topenv %> */
|
||||
|
|
@ -0,0 +1 @@
|
|||
"<% @var filename %>" = quicklisp-to-nix-packages."<% @var host-filename %>";
|
||||
327
pkgs/development/lisp-modules/quicklisp-to-nix/ql-to-nix.lisp
Normal file
327
pkgs/development/lisp-modules/quicklisp-to-nix/ql-to-nix.lisp
Normal file
|
|
@ -0,0 +1,327 @@
|
|||
(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)
|
||||
|
||||
;; 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 *required-systems* nil)
|
||||
|
||||
(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 (scan "^[a-zA-Z_]" s) "" "_")
|
||||
(loop
|
||||
for x in (map 'list 'identity s)
|
||||
collect
|
||||
(case x
|
||||
(#\/ "_slash_")
|
||||
(#\\ "_backslash_")
|
||||
(#\_ "__")
|
||||
(#\. "_dot_")
|
||||
(#\+ "_plus_")
|
||||
(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 (escape-filename (string 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)
|
||||
"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)
|
||||
(execute-emb
|
||||
"nix-package"
|
||||
:env (system-data system)))
|
||||
|
||||
(defun nix-invocation (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*
|
||||
((seen (make-hash-table :test 'equal)))
|
||||
(loop
|
||||
with queue := systems
|
||||
with res := nil
|
||||
while queue
|
||||
for next := (pop queue)
|
||||
for old := (gethash next seen)
|
||||
for data := (unless old (system-data next))
|
||||
for deps := (getf data :dependencies)
|
||||
for siblings := (getf data :siblings)
|
||||
unless old do
|
||||
(progn
|
||||
(push next res)
|
||||
(setf queue (append queue deps)))
|
||||
do (setf (gethash next seen) t)
|
||||
finally (return res))))
|
||||
|
||||
(defun ql-to-nix (target-directory)
|
||||
(let*
|
||||
((systems
|
||||
(split
|
||||
(format nil "~%")
|
||||
(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 (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>] [--cacheFaslDir <path>] <work-dir>
|
||||
Arguments:
|
||||
--cacheSystemInfoDir Store computed system info in the given directory
|
||||
--cacheFaslDir Store intermediate fast load files 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"
|
||||
(dolist (system *required-systems*)
|
||||
(asdf:make 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))
|
||||
|
|
@ -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))
|
||||
493
pkgs/development/lisp-modules/quicklisp-to-nix/system-info.lisp
Normal file
493
pkgs/development/lisp-modules/quicklisp-to-nix/system-info.lisp
Normal file
|
|
@ -0,0 +1,493 @@
|
|||
(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)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defparameter *implementation-systems*
|
||||
(append
|
||||
#+sbcl(list :sb-posix :sb-bsd-sockets :sb-rotate-byte :sb-cltl2
|
||||
:sb-introspect :sb-rt :sb-concurrency)))
|
||||
(mapcar (function require) *implementation-systems*))
|
||||
|
||||
(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!
|
||||
|
||||
;; (Implementation-provided dependencies are special, though)
|
||||
|
||||
;; 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
|
||||
"serapeum/docs" ;; Weird issue with FUN-INFO redefinition
|
||||
"spinneret/cl-markdown" ;; Weird issue with FUN-INFO redefinition
|
||||
"spinneret/ps" ;; Weird issue with FUN-INFO redefinition
|
||||
"spinneret/tests") ;; Weird issue with FUN-INFO redefinition
|
||||
"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::*registered-systems* :do
|
||||
; for an unclear reason, a literal 0 which is not a key in the hash table gets observed
|
||||
(when (and (gethash system-name asdf/find-system::*registered-systems*)
|
||||
(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
|
||||
(or
|
||||
(ignore-errors (asdf:system-description (asdf:find-system system)))
|
||||
"System lacks description"))
|
||||
(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))))
|
||||
|
||||
(mapcar (function require) *implementation-systems*)
|
||||
|
||||
(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))
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
{stdenv, lib, fetchurl, pkgs, clwrapper}:
|
||||
let quicklisp-to-nix-packages = rec {
|
||||
inherit stdenv lib fetchurl clwrapper pkgs quicklisp-to-nix-packages;
|
||||
|
||||
callPackage = pkgs.lib.callPackageWith quicklisp-to-nix-packages;
|
||||
buildLispPackage = callPackage ./define-package.nix;
|
||||
qlOverrides = callPackage ./quicklisp-to-nix-overrides.nix {};
|
||||
<% @loop invocations %>
|
||||
<% @var code %>
|
||||
<% @endloop %>
|
||||
};
|
||||
in
|
||||
quicklisp-to-nix-packages
|
||||
178
pkgs/development/lisp-modules/quicklisp-to-nix/util.lisp
Normal file
178
pkgs/development/lisp-modules/quicklisp-to-nix/util.lisp
Normal file
|
|
@ -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)))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue