diff options
Diffstat (limited to 'pkgs/development/lisp-modules-obsolete/quicklisp-to-nix')
8 files changed, 0 insertions, 1118 deletions
diff --git a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/invocation.emb b/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/invocation.emb deleted file mode 100644 index 3a0c5cb5fc2ca..0000000000000 --- a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/invocation.emb +++ /dev/null @@ -1,7 +0,0 @@ - "<% @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 %> - })); diff --git a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/nix-package.emb b/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/nix-package.emb deleted file mode 100644 index 6b0940ba55a64..0000000000000 --- a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/nix-package.emb +++ /dev/null @@ -1,23 +0,0 @@ -/* 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 %> */ diff --git a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/parasitic-invocation.emb b/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/parasitic-invocation.emb deleted file mode 100644 index bdee1c6dcf165..0000000000000 --- a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/parasitic-invocation.emb +++ /dev/null @@ -1 +0,0 @@ - "<% @var filename %>" = quicklisp-to-nix-packages."<% @var host-filename %>"; diff --git a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/ql-to-nix.lisp b/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/ql-to-nix.lisp deleted file mode 100644 index 4a82b6cafa6fe..0000000000000 --- a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/ql-to-nix.lisp +++ /dev/null @@ -1,327 +0,0 @@ -(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)) diff --git a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/quicklisp-bootstrap.lisp b/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/quicklisp-bootstrap.lisp deleted file mode 100644 index 1c4a682007fdd..0000000000000 --- a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/quicklisp-bootstrap.lisp +++ /dev/null @@ -1,76 +0,0 @@ -(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-obsolete/quicklisp-to-nix/system-info.lisp b/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/system-info.lisp deleted file mode 100644 index af8d450272c05..0000000000000 --- a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/system-info.lisp +++ /dev/null @@ -1,493 +0,0 @@ -(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)) diff --git a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/top-package.emb b/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/top-package.emb deleted file mode 100644 index 38b4f67aa1c3b..0000000000000 --- a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/top-package.emb +++ /dev/null @@ -1,13 +0,0 @@ -{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 diff --git a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/util.lisp b/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/util.lisp deleted file mode 100644 index 7b40430427351..0000000000000 --- a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/util.lisp +++ /dev/null @@ -1,178 +0,0 @@ -(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))))) |