250 lines
9.9 KiB
Common Lisp
250 lines
9.9 KiB
Common Lisp
(in-package #:quicklisp)
|
|
|
|
(defun show-wrapped-list (words &key (indent 4) (margin 60))
|
|
(let ((*print-right-margin* margin)
|
|
(*print-pretty* t)
|
|
(*print-escape* nil)
|
|
(prefix (make-string indent :initial-element #\Space)))
|
|
(pprint-logical-block (nil words :per-line-prefix prefix)
|
|
(pprint-fill *standard-output* (sort (copy-seq words) #'string<) nil))
|
|
(fresh-line)
|
|
(finish-output)))
|
|
|
|
(defun recursively-install (name)
|
|
(labels ((recurse (name)
|
|
(let ((system (find-system name)))
|
|
(unless system
|
|
(error "Unknown system ~S" name))
|
|
(ensure-installed system)
|
|
(mapcar #'recurse (required-systems system))
|
|
name)))
|
|
(with-consistent-dists
|
|
(recurse name))))
|
|
|
|
(defclass load-strategy ()
|
|
((name
|
|
:initarg :name
|
|
:accessor name)
|
|
(asdf-systems
|
|
:initarg :asdf-systems
|
|
:accessor asdf-systems)
|
|
(quicklisp-systems
|
|
:initarg :quicklisp-systems
|
|
:accessor quicklisp-systems)))
|
|
|
|
(defmethod print-object ((strategy load-strategy) stream)
|
|
(print-unreadable-object (strategy stream :type t)
|
|
(format stream "~S (~D asdf, ~D quicklisp)"
|
|
(name strategy)
|
|
(length (asdf-systems strategy))
|
|
(length (quicklisp-systems strategy)))))
|
|
|
|
(defgeneric quicklisp-releases (strategy)
|
|
(:method (strategy)
|
|
(remove-duplicates (mapcar 'release (quicklisp-systems strategy)))))
|
|
|
|
(defgeneric quicklisp-release-table (strategy)
|
|
(:method ((strategy load-strategy))
|
|
(let ((table (make-hash-table)))
|
|
(dolist (system (quicklisp-systems strategy))
|
|
(push system (gethash (release system) table nil)))
|
|
table)))
|
|
|
|
(define-condition system-not-found (error)
|
|
((name
|
|
:initarg :name
|
|
:reader system-not-found-name))
|
|
(:report (lambda (condition stream)
|
|
(format stream "System ~S not found"
|
|
(system-not-found-name condition))))
|
|
(:documentation "This condition is signaled by QUICKLOAD when a
|
|
system given to load is not available via ASDF or a Quicklisp
|
|
dist."))
|
|
|
|
(defun compute-load-strategy (name)
|
|
(setf name (string-downcase name))
|
|
(let ((asdf-systems '())
|
|
(quicklisp-systems '()))
|
|
(labels ((recurse (name)
|
|
(let ((asdf-system (asdf:find-system name nil))
|
|
(quicklisp-system (find-system name)))
|
|
(cond (asdf-system
|
|
(push asdf-system asdf-systems))
|
|
(quicklisp-system
|
|
(push quicklisp-system quicklisp-systems)
|
|
(dolist (subname (required-systems quicklisp-system))
|
|
(recurse subname)))
|
|
(t
|
|
(cerror "Try again"
|
|
'system-not-found
|
|
:name name)
|
|
(recurse name))))))
|
|
(with-consistent-dists
|
|
(recurse name)))
|
|
(make-instance 'load-strategy
|
|
:name name
|
|
:asdf-systems (remove-duplicates asdf-systems)
|
|
:quicklisp-systems (remove-duplicates quicklisp-systems))))
|
|
|
|
(defun show-load-strategy (strategy)
|
|
(format t "To load ~S:~%" (name strategy))
|
|
(let ((asdf-systems (asdf-systems strategy))
|
|
(releases (quicklisp-releases strategy)))
|
|
(when asdf-systems
|
|
(format t " Load ~D ASDF system~:P:~%" (length asdf-systems))
|
|
(show-wrapped-list (mapcar 'asdf:component-name asdf-systems)))
|
|
(when releases
|
|
(format t " Install ~D Quicklisp release~:P:~%" (length releases))
|
|
(show-wrapped-list (mapcar 'name releases)))))
|
|
|
|
(defvar *macroexpand-progress-in-progress* nil)
|
|
|
|
(defun macroexpand-progress-fun (old-hook &key (char #\.)
|
|
(chars-per-line 50)
|
|
(forms-per-char 250))
|
|
(let ((output-so-far 0)
|
|
(seen-so-far 0))
|
|
(labels ((finish-line ()
|
|
(when (plusp output-so-far)
|
|
(dotimes (i (- chars-per-line output-so-far))
|
|
(write-char char))
|
|
(terpri)
|
|
(setf output-so-far 0)))
|
|
(show-string (string)
|
|
(let* ((length (length string))
|
|
(new-output (+ length output-so-far)))
|
|
(cond ((< chars-per-line new-output)
|
|
(finish-line)
|
|
(write-string string)
|
|
(setf output-so-far length))
|
|
(t
|
|
(write-string string)
|
|
(setf output-so-far new-output))))
|
|
(finish-output))
|
|
(show-package (name)
|
|
;; Only show package markers when compiling. Showing
|
|
;; them when loading shows a bunch of ASDF system
|
|
;; package noise.
|
|
(when *compile-file-pathname*
|
|
(finish-line)
|
|
(show-string (format nil "[package ~(~A~)]" name)))))
|
|
(lambda (fun form env)
|
|
(when (and (consp form)
|
|
(eq (first form) 'cl:defpackage)
|
|
(ignore-errors (string (second form))))
|
|
(show-package (second form)))
|
|
(incf seen-so-far)
|
|
(when (<= forms-per-char seen-so-far)
|
|
(setf seen-so-far 0)
|
|
(write-char char)
|
|
(finish-output)
|
|
(incf output-so-far)
|
|
(when (<= chars-per-line output-so-far)
|
|
(setf output-so-far 0)
|
|
(terpri)
|
|
(finish-output)))
|
|
(funcall old-hook fun form env)))))
|
|
|
|
(defun call-with-macroexpand-progress (fun)
|
|
(let ((*macroexpand-hook* (if *macroexpand-progress-in-progress*
|
|
*macroexpand-hook*
|
|
(macroexpand-progress-fun *macroexpand-hook*)))
|
|
(*macroexpand-progress-in-progress* t))
|
|
(funcall fun)
|
|
(terpri)))
|
|
|
|
(defun apply-load-strategy (strategy)
|
|
(map nil 'ensure-installed (quicklisp-releases strategy))
|
|
(call-with-macroexpand-progress
|
|
(lambda ()
|
|
(format t "~&; Loading ~S~%" (name strategy))
|
|
(asdf:load-system (name strategy) :verbose nil))))
|
|
|
|
(defun autoload-system-and-dependencies (name &key prompt)
|
|
"Try to load the system named by NAME, automatically loading any
|
|
Quicklisp-provided systems first, and catching ASDF missing
|
|
dependencies too if possible."
|
|
(setf name (string-downcase name))
|
|
(with-simple-restart (abort "Give up on ~S" name)
|
|
(let ((tried-so-far (make-hash-table :test 'equalp)))
|
|
(tagbody
|
|
retry
|
|
(handler-case
|
|
(let ((strategy (compute-load-strategy name)))
|
|
(show-load-strategy strategy)
|
|
(when (or (not prompt)
|
|
(press-enter-to-continue))
|
|
(apply-load-strategy strategy)))
|
|
(asdf:missing-dependency-of-version (c)
|
|
;; Nothing Quicklisp can do to recover from this, so just
|
|
;; resignal
|
|
(error c))
|
|
(asdf:missing-dependency (c)
|
|
(let ((parent (asdf::missing-required-by c))
|
|
(missing (asdf::missing-requires c)))
|
|
(typecase parent
|
|
((or null asdf:system)
|
|
;; NIL parent comes from :defsystem-depends-on failures
|
|
(if (gethash missing tried-so-far)
|
|
(error "Dependency looping -- already tried to load ~
|
|
~A" missing)
|
|
(setf (gethash missing tried-so-far) missing))
|
|
(autoload-system-and-dependencies missing
|
|
:prompt prompt)
|
|
(go retry))
|
|
(t
|
|
;; Error isn't from a system dependency, so there's
|
|
;; nothing to autoload
|
|
(error c))))))))
|
|
name))
|
|
|
|
(defvar *initial-dist-url*
|
|
"http://beta.quicklisp.org/dist/quicklisp.txt")
|
|
|
|
(defun dists-initialized-p ()
|
|
(not (not (ignore-errors (truename (qmerge "dists/"))))))
|
|
|
|
(defun quickstart-parameter (name &optional default)
|
|
(let* ((package (find-package '#:quicklisp-quickstart))
|
|
(symbol (and package (find-symbol (string '#:*quickstart-parameters*)
|
|
package)))
|
|
(plist (and symbol (symbol-value symbol)))
|
|
(parameter (and plist (getf plist name))))
|
|
(or parameter default)))
|
|
|
|
(defun maybe-initial-setup ()
|
|
"Run the steps needed when Quicklisp setup is run for the first time
|
|
after the quickstart installation."
|
|
(let ((quickstart-proxy-url (quickstart-parameter :proxy-url))
|
|
(quickstart-initial-dist-url (quickstart-parameter :initial-dist-url)))
|
|
(when (and quickstart-proxy-url (not *proxy-url*))
|
|
(setf *proxy-url* quickstart-proxy-url)
|
|
(setf (config-value "proxy-url") quickstart-proxy-url))
|
|
(unless (dists-initialized-p)
|
|
(let ((target (qmerge "dists/quicklisp/distinfo.txt"))
|
|
(url (or quickstart-initial-dist-url
|
|
*initial-dist-url*)))
|
|
(ensure-directories-exist target)
|
|
(install-dist url :prompt nil)))))
|
|
|
|
(defun setup ()
|
|
(unless (member 'system-definition-searcher
|
|
asdf:*system-definition-search-functions*)
|
|
(setf asdf:*system-definition-search-functions*
|
|
(append asdf:*system-definition-search-functions*
|
|
(list 'local-projects-searcher
|
|
'system-definition-searcher))))
|
|
(let ((files (nconc (directory (qmerge "local-init/*.lisp"))
|
|
(directory (qmerge "local-init/*.cl")))))
|
|
(with-simple-restart (abort "Stop loading local setup files")
|
|
(dolist (file (sort files #'string< :key #'pathname-name))
|
|
(with-simple-restart (skip "Skip local setup file ~S" file)
|
|
;; Don't try to load Emacs lock files, other hidden files
|
|
(unless (char= (char (pathname-name file) 0)
|
|
#\.)
|
|
(load file))))))
|
|
(maybe-initial-setup)
|
|
(ensure-directories-exist (qmerge "local-projects/"))
|
|
(pushnew :quicklisp *features*)
|
|
t)
|