forked from quicklisp/quicklisp-client
/
setup.lisp
216 lines (199 loc) · 8.32 KB
/
setup.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
(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)))))
(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
(error 'system-not-found
:name 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:oos 'asdf:load-op (name strategy) :verbose nil))))
(defun autoload-system-and-dependencies (name &key prompt)
(setf name (string-downcase name))
(with-simple-restart (abort "Give up on ~S" name)
(let ((strategy (compute-load-strategy name)))
(show-load-strategy strategy)
(when (or (not prompt)
(press-enter-to-continue))
(tagbody
retry
(handler-bind
((asdf:missing-dependency
(lambda (c)
(let ((parent (asdf::missing-required-by c))
(missing (asdf::missing-requires c)))
(when (typep parent 'asdf:system)
(autoload-system-and-dependencies missing
:prompt prompt)
(go retry))))))
(apply-load-strategy strategy)))))
name))
(defvar *initial-dist-url*
"http://beta.quicklisp.org/dist/quicklisp.txt")
(defun maybe-initial-setup ()
;; Is this running under the quicklisp bootstrap?
(let ((bootstrap-package (find-package 'quicklisp-quickstart)))
(when bootstrap-package
(let* ((proxy (find-symbol (string '#:*proxy-url*) bootstrap-package))
(proxy-value (and proxy (symbol-value proxy))))
(when (and proxy-value (not *proxy-url*))
(setf *proxy-url* proxy-value)
(setf (config-value "proxy-url") proxy-value)))))
(unless (ignore-errors (truename (qmerge "dists/")))
(let ((target (qmerge "dists/quicklisp/distinfo.txt")))
(ensure-directories-exist target)
(fetch *initial-dist-url* target)
(enable (find-dist "quicklisp")))))
(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)