···1-Prerequisite: have Quicklisp installed somehow.
00023-Add to LD_LIBRARY_PATH all the things listed in quicklisp-to-nix-overrides.nix
4-for library propagatedBuildInputs (a lot of these are done via addNativeLibs).
56-Current list is:
7-openssl fuse libuv mariadb libfixposix libev sqlite
00000089-Add the needed system names to quicklisp-to-nix-systems.txt and load
10-quicklisp-to-nix/ql-to-nix.lisp and call
11-(ql-to-nix "/path/to/nixpkgs/pkgs/development/lisp-modules/") which is often
12-just (ql-to-nix ".")
13-14-Add native libraries and whatever else is needed to overrides.
15-16-The lispPackages set is supposed to be buildable in its entirety.
···1+Want to add a package? There are 3 simple steps!
2+1. Add the needed system names to quicklisp-to-nix-systems.txt.
3+2. cd <path to quicklisp-to-nix-systems.txt> ; nix-shell --run 'quicklisp-to-nix .'
4+3. Add native libraries and whatever else is needed to quicklisp-to-nix-overrides.nix.
56+To update to a more recent quicklisp dist modify
7+lispPackages.quicklisp to have a more recent distinfo.
89+quicklisp-to-nix-system-info is responsible for installing a quicklisp
10+package into an isolated environment and figuring out which packages
11+are required by that system. It also extracts other information that
12+is readily available once the system is loaded. The information
13+produced by this program is fed into quicklisp-to-nix. You usually
14+don't need to run this program unless you're trying to understand why
15+quicklisp-to-nix failed to handle a system. The technique used by
16+quicklisp-to-nix-system-info is described in its source.
1718+quicklisp-to-nix is responsible for reading
19+quicklisp-to-nix-systems.txt, running quicklisp-to-nix-system-info,
20+and generating the nix packages associated with the closure of
21+quicklisp systems.
0000
···9available. If it is, then the library provides the
10REGULAR-EXPRESSION-TEMPLATE.'';
1112- deps = [ args."cl-ppcre" ];
1314 src = fetchurl {
15 url = ''http://beta.quicklisp.org/archive/cl-unification/2017-06-30/cl-unification-20170630-git.tgz'';
16 sha256 = ''063xcf2ib3gdpjr39bgkaj6msylzdhbdjsj458w08iyidbxivwlz'';
17 };
18-19 packageName = "cl-ppcre-template";
2021- overrides = x: {
22- postInstall = ''
23- find "$out/lib/common-lisp/" -name '*.asd' | grep -iv '/cl-ppcre-template[.]asd${"$"}' |
24- while read f; do
25- env -i \
26- NIX_LISP="$NIX_LISP" \
27- NIX_LISP_PRELAUNCH_HOOK="nix_lisp_run_single_form '(progn
28- (asdf:load-system :$(basename "$f" .asd))
29- (asdf:perform (quote asdf:compile-bundle-op) :$(basename "$f" .asd))
30- (ignore-errors (asdf:perform (quote asdf:deliver-asd-op) :$(basename "$f" .asd)))
31- )'" \
32- "$out"/bin/*-lisp-launcher.sh ||
33- mv "$f"{,.sibling}; done || true
34- '';
35- };
36}
37-/* (SYSTEM cl-ppcre-template DESCRIPTION A system used to conditionally load the CL-PPCRE Template.
03839This system is not required and it is handled only if CL-PPCRE is
40available. If it is, then the library provides the
41REGULAR-EXPRESSION-TEMPLATE.
42- SHA256 063xcf2ib3gdpjr39bgkaj6msylzdhbdjsj458w08iyidbxivwlz URL http://beta.quicklisp.org/archive/cl-unification/2017-06-30/cl-unification-20170630-git.tgz
43- MD5 f6bf197ca8c79c935efe3a3c25953044 NAME cl-ppcre-template TESTNAME NIL FILENAME cl-ppcre-template DEPS ((NAME cl-ppcre FILENAME cl-ppcre)) DEPENDENCIES
44- (cl-ppcre) VERSION cl-unification-20170630-git SIBLINGS (cl-unification-lib cl-unification-test cl-unification)) */
000000
···9available. If it is, then the library provides the
10REGULAR-EXPRESSION-TEMPLATE.'';
1112+ deps = [ args."cl-ppcre" args."cl-unification" ];
1314 src = fetchurl {
15 url = ''http://beta.quicklisp.org/archive/cl-unification/2017-06-30/cl-unification-20170630-git.tgz'';
16 sha256 = ''063xcf2ib3gdpjr39bgkaj6msylzdhbdjsj458w08iyidbxivwlz'';
17 };
18+19 packageName = "cl-ppcre-template";
2021+ asdFilesToKeep = ["cl-ppcre-template.asd"];
22+ overrides = x: x;
000000000000023}
24+/* (SYSTEM cl-ppcre-template DESCRIPTION
25+ A system used to conditionally load the CL-PPCRE Template.
2627This system is not required and it is handled only if CL-PPCRE is
28available. If it is, then the library provides the
29REGULAR-EXPRESSION-TEMPLATE.
30+ SHA256 063xcf2ib3gdpjr39bgkaj6msylzdhbdjsj458w08iyidbxivwlz URL
31+ http://beta.quicklisp.org/archive/cl-unification/2017-06-30/cl-unification-20170630-git.tgz
32+ MD5 f6bf197ca8c79c935efe3a3c25953044 NAME cl-ppcre-template FILENAME
33+ cl-ppcre-template DEPS
34+ ((NAME cl-ppcre FILENAME cl-ppcre)
35+ (NAME cl-unification FILENAME cl-unification))
36+ DEPENDENCIES (cl-ppcre cl-unification) VERSION cl-unification-20170630-git
37+ SIBLINGS (cl-unification-lib cl-unification-test cl-unification) PARASITES
38+ NIL) */
···11 url = ''http://beta.quicklisp.org/archive/closer-mop/2017-07-25/closer-mop-20170725-git.tgz'';
12 sha256 = ''0qc4zh4zicv3zm4bw8c3s2r2bjbx2bp31j69lwiz1mdl9xg0nhsc'';
13 };
14-15 packageName = "closer-mop";
1617- overrides = x: {
18- postInstall = ''
19- find "$out/lib/common-lisp/" -name '*.asd' | grep -iv '/closer-mop[.]asd${"$"}' |
20- while read f; do
21- env -i \
22- NIX_LISP="$NIX_LISP" \
23- NIX_LISP_PRELAUNCH_HOOK="nix_lisp_run_single_form '(progn
24- (asdf:load-system :$(basename "$f" .asd))
25- (asdf:perform (quote asdf:compile-bundle-op) :$(basename "$f" .asd))
26- (ignore-errors (asdf:perform (quote asdf:deliver-asd-op) :$(basename "$f" .asd)))
27- )'" \
28- "$out"/bin/*-lisp-launcher.sh ||
29- mv "$f"{,.sibling}; done || true
30- '';
31- };
32}
33/* (SYSTEM closer-mop DESCRIPTION
34 Closer to MOP is a compatibility layer that rectifies many of the absent or incorrect CLOS MOP features across a broad range of Common Lisp implementations.
35- SHA256 0qc4zh4zicv3zm4bw8c3s2r2bjbx2bp31j69lwiz1mdl9xg0nhsc URL http://beta.quicklisp.org/archive/closer-mop/2017-07-25/closer-mop-20170725-git.tgz MD5
36- 308f9e8e4ea4573c7b6820055b6f171d NAME closer-mop TESTNAME NIL FILENAME closer-mop DEPS NIL DEPENDENCIES NIL VERSION 20170725-git SIBLINGS NIL) */
00
···11 url = ''http://beta.quicklisp.org/archive/closer-mop/2017-07-25/closer-mop-20170725-git.tgz'';
12 sha256 = ''0qc4zh4zicv3zm4bw8c3s2r2bjbx2bp31j69lwiz1mdl9xg0nhsc'';
13 };
14+15 packageName = "closer-mop";
1617+ asdFilesToKeep = ["closer-mop.asd"];
18+ overrides = x: x;
000000000000019}
20/* (SYSTEM closer-mop DESCRIPTION
21 Closer to MOP is a compatibility layer that rectifies many of the absent or incorrect CLOS MOP features across a broad range of Common Lisp implementations.
22+ SHA256 0qc4zh4zicv3zm4bw8c3s2r2bjbx2bp31j69lwiz1mdl9xg0nhsc URL
23+ http://beta.quicklisp.org/archive/closer-mop/2017-07-25/closer-mop-20170725-git.tgz
24+ MD5 308f9e8e4ea4573c7b6820055b6f171d NAME closer-mop FILENAME closer-mop
25+ DEPS NIL DEPENDENCIES NIL VERSION 20170725-git SIBLINGS NIL PARASITES NIL) */
···1+(unless (find-package :ql-to-nix-util)
2+ (load "ql-to-nix-util.lisp"))
3+(defpackage :ql-to-nix-quicklisp-bootstrap
4+ (:use :common-lisp :ql-to-nix-util)
5+ (:export #:with-quicklisp)
6+ (:documentation
7+ "This package provides a way to create a temporary quicklisp installation."))
8+(in-package :ql-to-nix-quicklisp-bootstrap)
9+10+(declaim (optimize (debug 3) (speed 0) (space 0) (compilation-speed 0) (safety 3)))
11+12+;; This file cannot have any dependencies beyond quicklisp and asdf.
13+;; Otherwise, we'll miss some dependencies!
14+15+(defvar *quicklisp*
16+ (namestring (pathname-as-directory (uiop:getenv "quicklisp")))
17+ "The path to the nix quicklisp package.")
18+19+(defun prepare-quicklisp-dir (target-dir quicklisp-prototype-dir)
20+ "Install quicklisp into the specified `target-dir'.
21+22+`quicklisp-prototype-dir' should be the path to the quicklisp nix
23+package."
24+ (ensure-directories-exist target-dir)
25+ (dolist (subdir '(#P"dists/quicklisp/" #P"tmp/" #P"local-projects/" #P"quicklisp/"))
26+ (ensure-directories-exist (merge-pathnames subdir target-dir)))
27+ (with-open-file (s (merge-pathnames #P"dists/quicklisp/enabled.txt" target-dir) :direction :output :if-exists :supersede)
28+ (format s "1~%"))
29+ (uiop:copy-file
30+ (merge-pathnames #P"lib/common-lisp/quicklisp/quicklisp-distinfo.txt" quicklisp-prototype-dir)
31+ (merge-pathnames #P"dists/quicklisp/distinfo.txt" target-dir))
32+ (uiop:copy-file
33+ (merge-pathnames #P"lib/common-lisp/quicklisp/asdf.lisp" quicklisp-prototype-dir)
34+ (merge-pathnames #P"asdf.lisp" target-dir))
35+ (uiop:copy-file
36+ (merge-pathnames #P"lib/common-lisp/quicklisp/setup.lisp" quicklisp-prototype-dir)
37+ (merge-pathnames #P"setup.lisp" target-dir))
38+ (copy-directory-tree
39+ (merge-pathnames #P"lib/common-lisp/quicklisp/quicklisp/" quicklisp-prototype-dir)
40+ (merge-pathnames #P"quicklisp/" target-dir)))
41+42+(defun call-with-quicklisp (function &key (target-dir :temp) (cache-dir :temp))
43+ "Invoke the given function with the path to a quicklisp installation.
44+45+Quicklisp will be loaded before the function is called. `target-dir'
46+can either be a pathname for the place where quicklisp should be
47+installed or `:temp' to request installation in a temporary directory.
48+`cache-dir' can either be a pathname for a place to store fasls or
49+`:temp' to request caching in a temporary directory."
50+ (when (find-package :ql)
51+ (error "Already loaded quicklisp in this process"))
52+ (labels
53+ ((make-ql (ql-dir)
54+ (prepare-quicklisp-dir ql-dir *quicklisp*)
55+ (with-temporary-asdf-cache (ql-dir)
56+ (load (merge-pathnames #P"setup.lisp" ql-dir))
57+ (if (eq :temp cache-dir)
58+ (funcall function ql-dir)
59+ (with-asdf-cache (ql-dir cache-dir)
60+ (funcall function ql-dir))))))
61+ (if (eq :temp target-dir)
62+ (with-temporary-directory (dir)
63+ (make-ql dir))
64+ (make-ql target-dir))))
65+66+(defmacro with-quicklisp ((quicklisp-dir) (&key (cache-dir :temp)) &body body)
67+ "Install quicklisp in a temporary directory, load it, bind
68+`quicklisp-dir' to the path where quicklisp was installed, and then
69+evaluate `body'.
70+71+`cache-dir' can either be a pathname for a place to store fasls or
72+`:temp' to request caching in a temporary directory."
73+ `(call-with-quicklisp
74+ (lambda (,quicklisp-dir)
75+ ,@body)
76+ :cache-dir ,cache-dir))
···1+(unless (find-package :ql-to-nix-util)
2+ (load "util.lisp"))
3+(unless (find-package :ql-to-nix-quicklisp-bootstrap)
4+ (load "quicklisp-bootstrap.lisp"))
5+(defpackage :ql-to-nix-system-info
6+ (:use :common-lisp :ql-to-nix-quicklisp-bootstrap :ql-to-nix-util)
7+ (:export #:dump-image))
8+(in-package :ql-to-nix-system-info)
9+10+(declaim (optimize (debug 3) (speed 0) (space 0) (compilation-speed 0) (safety 3)))
11+12+;; This file cannot have any dependencies beyond quicklisp and asdf.
13+;; Otherwise, we'll miss some dependencies!
14+15+;; We can't load quicklisp until runtime (at which point we'll create
16+;; an isolated quicklisp installation). These wrapper functions are
17+;; nicer than funcalling intern'd symbols every time we want to talk
18+;; to quicklisp.
19+(wrap :ql apply-load-strategy)
20+(wrap :ql compute-load-strategy)
21+(wrap :ql show-load-strategy)
22+(wrap :ql quicklisp-systems)
23+(wrap :ql ensure-installed)
24+(wrap :ql quicklisp-releases)
25+(wrap :ql-dist archive-md5)
26+(wrap :ql-dist archive-url)
27+(wrap :ql-dist ensure-local-archive-file)
28+(wrap :ql-dist find-system)
29+(wrap :ql-dist local-archive-file)
30+(wrap :ql-dist name)
31+(wrap :ql-dist provided-systems)
32+(wrap :ql-dist release)
33+(wrap :ql-dist short-description)
34+(wrap :ql-dist system-file-name)
35+(wrap :ql-impl-util call-with-quiet-compilation)
36+37+(defvar *version* (uiop:getenv "version")
38+ "The version number of this program")
39+40+(defvar *main-system* nil
41+ "The name of the system we're trying to extract info from.")
42+43+(defvar *found-parasites* (make-hash-table :test #'equalp)
44+ "Names of systems which have been identified as parasites.
45+46+A system is parasitic if its name doesn't match the name of the file
47+it is defined in. So, for example, if foo and foo-bar are both
48+defined in a file named foo.asd, foo would be the host system and
49+foo-bar would be a parasitic system.
50+51+Parasitic systems are not generally loaded without loading the host
52+system first.
53+54+Keys are system names. Values are unspecified.")
55+56+(defvar *found-dependencies* (make-hash-table :test #'equalp)
57+ "Hash table containing the set of dependencies discovered while installing a system.
58+59+Keys are system names. Values are unspecified.")
60+61+(defun decode-asdf-dependency (name)
62+ "Translates an asdf system dependency description into a system name.
63+64+For example, translates (:version :foo \"1.0\") into \"foo\"."
65+ (etypecase name
66+ (symbol
67+ (setf name (symbol-name name)))
68+ (string)
69+ (cons
70+ (ecase (first name)
71+ (:version
72+ (warn "Discarding version information ~A" name)
73+ ;; There's nothing we can do about this. If the version we
74+ ;; have around is good enough, then we're golden. If it isn't
75+ ;; good enough, then we'll error out and let a human figure it
76+ ;; out.
77+ (setf name (second name))
78+ (return-from decode-asdf-dependency
79+ (decode-asdf-dependency name)))
80+81+ (:feature
82+ (if (find (second name) *features*)
83+ (return-from decode-asdf-dependency
84+ (decode-asdf-dependency (third name)))
85+ (progn
86+ (warn "Dropping dependency due to missing feature: ~A" name)
87+ (return-from decode-asdf-dependency nil))))
88+89+ (:require
90+ ;; This probably isn't a dependency we can satisfy using
91+ ;; quicklisp, but we might as well try anyway.
92+ (return-from decode-asdf-dependency
93+ (decode-asdf-dependency (second name)))))))
94+ (string-downcase name))
95+96+(defun found-new-parasite (system-name)
97+ "Record that the given system has been identified as a parasite."
98+ (setf system-name (decode-asdf-dependency system-name))
99+ (setf (gethash system-name *found-parasites*) t)
100+ (when (nth-value 1 (gethash system-name *found-dependencies*))
101+ (error "Found dependency on parasite")))
102+103+(defun known-parasite-p (system-name)
104+ "Have we previously identified this system as a parasite?"
105+ (nth-value 1 (gethash system-name *found-parasites*)))
106+107+(defun found-parasites ()
108+ "Return a vector containing all identified parasites."
109+ (let ((systems (make-array (hash-table-size *found-parasites*) :fill-pointer 0)))
110+ (loop :for system :being :the :hash-keys :of *found-parasites* :do
111+ (vector-push system systems))
112+ systems))
113+114+(defvar *track-dependencies* nil
115+ "When this variable is nil, found-new-dependency will not record
116+depdendencies.")
117+118+(defun parasitic-relationship-p (potential-host potential-parasite)
119+ "Returns t if potential-host and potential-parasite have a parasitic relationship.
120+121+See `*found-parasites*'."
122+ (let ((host-ql-system (find-system potential-host))
123+ (parasite-ql-system (find-system potential-parasite)))
124+ (and host-ql-system parasite-ql-system
125+ (not (equal (name host-ql-system)
126+ (name parasite-ql-system)))
127+ (equal (system-file-name host-ql-system)
128+ (system-file-name parasite-ql-system)))))
129+130+(defun found-new-dependency (name)
131+ "Record that the given system has been identified as a dependency.
132+133+The named system may not be recorded as a dependency. It may be left
134+out for any number of reasons. For example, if `*track-dependencies*'
135+is nil then this function does nothing. If the named system isn't a
136+quicklisp system, this function does nothing."
137+ (setf name (decode-asdf-dependency name))
138+ (unless name
139+ (return-from found-new-dependency))
140+ (unless *track-dependencies*
141+ (return-from found-new-dependency))
142+ (when (known-parasite-p name)
143+ (return-from found-new-dependency))
144+ (when (parasitic-relationship-p *main-system* name)
145+ (found-new-parasite name)
146+ (return-from found-new-dependency))
147+ (unless (find-system name)
148+ (return-from found-new-dependency))
149+ (setf (gethash name *found-dependencies*) t))
150+151+(defun forget-dependency (name)
152+ "Whoops. Did I say that was a dependency? My bad.
153+154+Be very careful using this function! You can remove a system from the
155+dependency list, but you can't remove other effects associated with
156+this system. For example, transitive dependencies might still be in
157+the dependency list."
158+ (setf name (decode-asdf-dependency name))
159+ (remhash name *found-dependencies*))
160+161+(defun found-dependencies ()
162+ "Return a vector containing all identified dependencies."
163+ (let ((systems (make-array (hash-table-size *found-dependencies*) :fill-pointer 0)))
164+ (loop :for system :being :the :hash-keys :of *found-dependencies* :do
165+ (vector-push system systems))
166+ systems))
167+168+(defun host-system (system-name)
169+ "If the given system is a parasite, return the name of the system that is its host.
170+171+See `*found-parasites*'."
172+ (let* ((system (find-system system-name))
173+ (host-file (system-file-name system)))
174+ (unless (equalp host-file system-name)
175+ host-file)))
176+177+(defun get-loaded (system)
178+ "Try to load the named system using quicklisp and record any
179+dependencies quicklisp is aware of.
180+181+Unlike `our-quickload', this function doesn't attempt to install
182+missing dependencies."
183+ ;; Let's get this party started!
184+ (let* ((strategy (compute-load-strategy system))
185+ (ql-systems (quicklisp-systems strategy)))
186+ (dolist (dep ql-systems)
187+ (found-new-dependency (name dep)))
188+ (show-load-strategy strategy)
189+ (labels
190+ ((make-go ()
191+ (apply-load-strategy strategy)))
192+ (call-with-quiet-compilation #'make-go)
193+ (let ((asdf-system (asdf:find-system system)))
194+ ;; If ASDF says that it needed a system, then we should
195+ ;; probably track that.
196+ (dolist (asdf-dep (asdf:component-sideway-dependencies asdf-system))
197+ (found-new-dependency asdf-dep))
198+ (dolist (asdf-dep (asdf:system-defsystem-depends-on asdf-system))
199+ (found-new-dependency asdf-dep))))))
200+201+(defun our-quickload (system)
202+ "Attempt to install a package like quicklisp would, but record any
203+dependencies that are detected during the install."
204+ (setf system (string-downcase system))
205+ ;; Load it quickly, but do it OUR way. Turns out our way is very
206+ ;; similar to the quicklisp way...
207+ (let ((already-tried (make-hash-table :test #'equalp))) ;; Case insensitive
208+ (tagbody
209+ retry
210+ (handler-case
211+ (get-loaded system)
212+ (asdf/find-component:missing-dependency (e)
213+ (let ((required-by (asdf/find-component:missing-required-by e))
214+ (missing (asdf/find-component:missing-requires e)))
215+ (unless (typep required-by 'asdf:system)
216+ (error e))
217+ (when (gethash missing already-tried)
218+ (error "Dependency loop? ~A" missing))
219+ (setf (gethash missing already-tried) t)
220+ (let ((parasitic-p (parasitic-relationship-p *main-system* missing)))
221+ (if parasitic-p
222+ (found-new-parasite missing)
223+ (found-new-dependency missing))
224+ ;; We always want to track the dependencies of systems
225+ ;; that share an asd file with the main system. The
226+ ;; whole asd file should be loadable. Otherwise, we
227+ ;; don't want to include transitive dependencies.
228+ (let ((*track-dependencies* parasitic-p))
229+ (our-quickload missing)))
230+ (format t "Attempting to load ~A again~%" system)
231+ (go retry)))))))
232+233+(defvar *blacklisted-parasites*
234+ #("hu.dwim.stefil/documentation" ;; This system depends on :hu.dwim.stefil.test, but it should depend on hu.dwim.stefil/test
235+ "named-readtables/doc" ;; Dependency cycle between named-readtabes and mgl-pax
236+ "symbol-munger-test" ;; Dependency cycle between lisp-unit2 and symbol-munger
237+ "cl-postgres-simple-date-tests" ;; Dependency cycle between cl-postgres and simple-date
238+ "cl-containers/with-variates") ;; Symbol conflict between cl-variates:next-element, metabang.utilities:next-element
239+ "A vector of systems that shouldn't be loaded by `quickload-parasitic-systems'.
240+241+These systems are known to be troublemakers. In some sense, all
242+parasites are troublemakers (you shouldn't define parasitic systems!).
243+However, these systems prevent us from generating nix packages and are
244+thus doubly evil.")
245+246+(defvar *blacklisted-parasites-table*
247+ (let ((ht (make-hash-table :test #'equalp)))
248+ (loop :for system :across *blacklisted-parasites* :do
249+ (setf (gethash system ht) t))
250+ ht)
251+ "A hash table where each entry in `*blacklisted-parasites*' is an
252+entry in the table.")
253+254+(defun blacklisted-parasite-p (system-name)
255+ "Returns non-nil if the named system is blacklisted"
256+ (nth-value 1 (gethash system-name *blacklisted-parasites-table*)))
257+258+(defun quickload-parasitic-systems (system)
259+ "Attempt to load all the systems defined in the same asd as the named system.
260+261+Blacklisted systems are skipped. Dependencies of the identified
262+parasitic systems will be tracked."
263+ (let* ((asdf-system (asdf:find-system system))
264+ (source-file (asdf:system-source-file asdf-system)))
265+ (cond
266+ (source-file
267+ (loop :for system-name :being :the :hash-keys :of asdf/find-system:*defined-systems* :do
268+ (when (and (parasitic-relationship-p system system-name)
269+ (not (blacklisted-parasite-p system-name)))
270+ (found-new-parasite system-name)
271+ (let ((*track-dependencies* t))
272+ (our-quickload system-name)))))
273+ (t
274+ (unless (or (equal "uiop" system)
275+ (equal "asdf" system))
276+ (warn "No source file for system ~A. Can't identify parasites." system))))))
277+278+(defun determine-dependencies (system)
279+ "Load the named system and return a sorted vector containing all the
280+quicklisp systems that were loaded to satisfy dependencies.
281+282+This function should probably only be called once per process!
283+Subsequent calls will miss dependencies identified by earlier calls."
284+ (tagbody
285+ retry
286+ (restart-case
287+ (let ((*standard-output* (make-broadcast-stream))
288+ (*trace-output* (make-broadcast-stream))
289+ (*main-system* system)
290+ (*track-dependencies* t))
291+ (our-quickload system)
292+ (quickload-parasitic-systems system))
293+ (try-again ()
294+ :report "Start the quickload over again"
295+ (go retry))
296+ (die ()
297+ :report "Just give up and die"
298+ (uiop:quit 1))))
299+300+ ;; Systems can't depend on themselves!
301+ (forget-dependency system)
302+ (values))
303+304+(defun parasitic-system-data (parasite-system)
305+ "Return a plist of information about the given known-parastic system.
306+307+Sometimes we are asked to provide information about a system that is
308+actually a parasite. The only correct response is to point them
309+toward the host system. The nix package for the host system should
310+have all the dependencies for this parasite already recorded.
311+312+The plist is only meant to be consumed by other parts of
313+quicklisp-to-nix."
314+ (let ((host-system (host-system parasite-system)))
315+ (list
316+ :system parasite-system
317+ :host host-system
318+ :name (string-downcase (format nil "~a" parasite-system))
319+ :host-name (string-downcase (format nil "~a" host-system)))))
320+321+(defun system-data (system)
322+ "Produce a plist describing a system.
323+324+The plist is only meant to be consumed by other parts of
325+quicklisp-to-nix."
326+ (when (host-system system)
327+ (return-from system-data
328+ (parasitic-system-data system)))
329+330+ (determine-dependencies system)
331+ (let*
332+ ((dependencies (sort (found-dependencies) #'string<))
333+ (parasites (coerce (sort (found-parasites) #'string<) 'list))
334+ (ql-system (find-system system))
335+ (ql-release (release ql-system))
336+ (ql-sibling-systems (provided-systems ql-release))
337+ (url (archive-url ql-release))
338+ (local-archive (local-archive-file ql-release))
339+ (local-url (format nil "file://~a" (pathname local-archive)))
340+ (archive-data
341+ (progn
342+ (ensure-local-archive-file ql-release)
343+ ;; Stuff this archive into the nix store. It was almost
344+ ;; certainly going to end up there anyway (since it will
345+ ;; probably be fetchurl'd for a nix package). Also, putting
346+ ;; it into the store also gives us the SHA we need.
347+ (nix-prefetch-url local-url)))
348+ (ideal-md5 (archive-md5 ql-release))
349+ (raw-dependencies (coerce dependencies 'list))
350+ (name (string-downcase (format nil "~a" system)))
351+ (ql-sibling-names
352+ (remove name (mapcar 'name ql-sibling-systems)
353+ :test 'equal))
354+ (dependencies raw-dependencies)
355+ (description (asdf:system-description (asdf:find-system system)))
356+ (release-name (short-description ql-release)))
357+ (list
358+ :system system
359+ :description description
360+ :sha256 (getf archive-data :sha256)
361+ :url url
362+ :md5 ideal-md5
363+ :name name
364+ :dependencies dependencies
365+ :siblings ql-sibling-names
366+ :release-name release-name
367+ :parasites parasites)))
368+369+(defvar *error-escape-valve* *error-output*
370+ "When `*error-output*' is rebound to inhibit spew, this stream will
371+still produce output.")
372+373+(defun print-usage-and-quit ()
374+ "Describe how to use this program... and then exit."
375+ (format *error-output* "Usage:
376+ ~A [--cacheDir <dir>] [--silent] [--debug] [--help|-h] <system-name>
377+Arguments:
378+ --cacheDir Store (and look for) compiled lisp files in the given directory
379+ --verbose Show compilation output
380+ --debug Enter the debugger when a fatal error is encountered
381+ --help Print usage and exit
382+ <system-name> The quicklisp system to examine
383+" (or (uiop:argv0) "quicklisp-to-nix-system-info"))
384+ (uiop:quit 2))
385+386+(defun main ()
387+ "Make it go."
388+ (let ((argv (uiop:command-line-arguments))
389+ cache-dir
390+ target-system
391+ verbose-p
392+ debug-p)
393+ (handler-bind
394+ ((warning
395+ (lambda (w)
396+ (format *error-escape-valve* "~A~%" w)))
397+ (error
398+ (lambda (e)
399+ (if debug-p
400+ (invoke-debugger e)
401+ (progn
402+ (format *error-escape-valve* "~
403+Failed to extract system info. Details are below. ~
404+Run with --debug and/or --verbose for more info.
405+~A~%" e)
406+ (uiop:quit 1))))))
407+ (loop :while argv :do
408+ (cond
409+ ((equal "--cacheDir" (first argv))
410+ (pop argv)
411+ (unless argv
412+ (error "--cacheDir expects an argument"))
413+ (setf cache-dir (first argv))
414+ (pop argv))
415+416+ ((equal "--verbose" (first argv))
417+ (setf verbose-p t)
418+ (pop argv))
419+420+ ((equal "--debug" (first argv))
421+ (setf debug-p t)
422+ (pop argv))
423+424+ ((or (equal "--help" (first argv))
425+ (equal "-h" (first argv)))
426+ (print-usage-and-quit))
427+428+ (t
429+ (setf target-system (pop argv))
430+ (when argv
431+ (error "Can only operate on one system")))))
432+433+ (unless target-system
434+ (print-usage-and-quit))
435+436+ (when cache-dir
437+ (setf cache-dir (pathname-as-directory (parse-namestring cache-dir))))
438+439+ (with-quicklisp (dir) (:cache-dir (or cache-dir :temp))
440+ (declare (ignore dir))
441+442+ (let (system-data)
443+ (let ((*error-output* (if verbose-p
444+ *error-output*
445+ (make-broadcast-stream)))
446+ (*standard-output* (if verbose-p
447+ *standard-output*
448+ (make-broadcast-stream)))
449+ (*trace-output* (if verbose-p
450+ *trace-output*
451+ (make-broadcast-stream))))
452+ (format *error-output*
453+ "quicklisp-to-nix-system-info ~A~%ASDF ~A~%Quicklisp ~A~%Compiler ~A ~A~%"
454+ *version*
455+ (asdf:asdf-version)
456+ (funcall (intern "CLIENT-VERSION" :ql))
457+ (lisp-implementation-type)
458+ (lisp-implementation-version))
459+ (setf system-data (system-data target-system)))
460+461+ (cond
462+ (system-data
463+ (format t "~W~%" system-data)
464+ (uiop:quit 0))
465+ (t
466+ (format *error-output* "Failed to determine system data~%")
467+ (uiop:quit 1))))))))
468+469+(defun dump-image ()
470+ "Make an executable"
471+ (setf uiop:*image-entry-point* #'main)
472+ (setf uiop:*lisp-interaction* nil)
473+ (uiop:dump-image "quicklisp-to-nix-system-info" :executable t))