context.lisp 25.7 KB
Newer Older
Eric Timmons's avatar
Eric Timmons committed
1
2
3
4
5
6
7
8
;;;; Context
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.

(uiop:define-package #:clpm/context
    (:use #:cl
          #:alexandria
9
          #:anaphora
10
          #:cl-ansi-text
Eric Timmons's avatar
Eric Timmons committed
11
          #:clpm/cache
12
          #:clpm/client
13
          #:clpm/config
Eric Timmons's avatar
Eric Timmons committed
14
          #:clpm/data
15
          #:clpm/log
16
          #:clpm/repos
Eric Timmons's avatar
Eric Timmons committed
17
          #:clpm/requirement
Eric Timmons's avatar
Eric Timmons committed
18
19
          #:clpm/source
          #:do-urlencode)
Eric Timmons's avatar
Eric Timmons committed
20
21
  (:export #:context
           #:context-add-requirement!
22
           #:context-anonymous-p
23
           #:context-asd-pathnames
24
           #:context-editable-primary-system-names
25
           #:context-find-system-asd-pathname
26
           #:context-fs-source
27
           #:context-installed-primary-system-names
Eric Timmons's avatar
Eric Timmons committed
28
           #:context-installed-systems
29
           #:context-name
Eric Timmons's avatar
Eric Timmons committed
30
           #:context-output-translations
Eric Timmons's avatar
Eric Timmons committed
31
32
           #:context-releases
           #:context-requirements
33
           #:context-reverse-dependencies
Eric Timmons's avatar
Eric Timmons committed
34
35
           #:context-sources
           #:context-system-releases
36
37
           #:context-to-asdf-source-registry-form
           #:context-to-asdf-source-registry.d-forms
38
39
           #:context-user-sources
           #:context-vcs-source
Eric Timmons's avatar
Eric Timmons committed
40
           #:context-visible-primary-system-names
41
           #:context-write-asdf-files
Eric Timmons's avatar
Eric Timmons committed
42
           #:copy-context
Eric Timmons's avatar
Eric Timmons committed
43
           #:load-anonymous-context-from-pathname
44
           #:save-context
45
46
           #:serialize-context-to-stream
           #:with-context))
Eric Timmons's avatar
Eric Timmons committed
47
48
49

(in-package #:clpm/context)

50
51
(setup-logger)

Eric Timmons's avatar
Eric Timmons committed
52
53
54
(defclass context ()
  ((name
    :initarg :name
55
56
57
58
    :accessor context-name
    :documentation
    "The name of the context. Either a string (if this is a global context) or a
pathname (if this is an anonymous context).")
Eric Timmons's avatar
Eric Timmons committed
59
60
61
62
   (requirements
    :initform nil
    :initarg :requirements
    :accessor context-requirements)
63
64
65
66
67
68
69
70
71
   (fs-source
    :accessor context-fs-source
    :documentation
    "The implicit filesystem source rooted for this context.")
   (vcs-source
    :accessor context-vcs-source
    :documentation
    "A VCS source to where raw vcs requirements can be homed.")
   (user-sources
Eric Timmons's avatar
Eric Timmons committed
72
    :initform nil
73
74
    :initarg :user-sources
    :accessor context-user-sources)
Eric Timmons's avatar
Eric Timmons committed
75
76
77
78
   (releases
    :initform nil
    :initarg :releases
    :accessor context-releases)
79
80
81
82
   (reverse-dependencies
    :initform nil
    :initarg :reverse-dependencies
    :accessor context-reverse-dependencies)
Eric Timmons's avatar
Eric Timmons committed
83
84
85
   (system-releases
    :initform nil
    :initarg :system-releases
86
87
88
89
90
91
    :accessor context-system-releases))
  (:documentation
   "Represents a snapshot of a context. Includes sources, the releases installed
in the context, the requirements that gave rise to those releases, etc. Contexts
can be named, global contexts, or anonymous."))

92
93
94
95
96
97
98
(defmethod initialize-instance :after ((context context) &key &allow-other-keys)
  (setf (context-fs-source context)
        (make-source 'fs-source
                     :name :implicit-file))
  (setf (context-vcs-source context)
        (make-source 'vcs-source :name :implicit-vcs)))

99
100
101
102
103
104
105
106
107
108
109
110
111
112
(defgeneric context-name (context))

(defmethod context-name ((context pathname))
  context)

(defmethod context-name ((context string))
  context)

(defmethod context-name ((context (eql nil)))
  (config-value :context))

(defgeneric context-anonymous-p (context))

(defmethod context-anonymous-p ((context context))
113
  (pathnamep (context-name context)))
Eric Timmons's avatar
Eric Timmons committed
114

115
116
117
118
119
120
121
122
123
(defmethod context-anonymous-p ((context pathname))
  t)

(defmethod context-anonymous-p ((context string))
  nil)

(defmethod context-anonymous-p ((context (eql nil)))
  nil)

Eric Timmons's avatar
Eric Timmons committed
124
125
126
(defun copy-context (context)
  (make-instance 'context
                 :name (context-name context)
127
                 :releases (copy-list (context-releases context))
Eric Timmons's avatar
Eric Timmons committed
128
                 :requirements (copy-list (context-requirements context))
129
                 :reverse-dependencies (copy-alist (context-reverse-dependencies context))
130
                 :user-sources (copy-list (context-user-sources context))
Eric Timmons's avatar
Eric Timmons committed
131
132
                 :system-releases (copy-list (context-system-releases context))))

Eric Timmons's avatar
Eric Timmons committed
133
134
135
(defun global-context-pathname (name)
  (clpm-data-pathname (list "contexts" name)))

Eric Timmons's avatar
Eric Timmons committed
136
137
138
139
140
141
142
(defun get-context (context-designator)
  (cond
    ((typep context-designator 'context)
     context-designator)
    ((stringp context-designator)
     (load-global-context context-designator nil))
    ((null context-designator)
143
     (load-global-context (config-value :context) nil))
144
145
146
    ((pathnamep context-designator)
     (load-anonymous-context-from-pathname (merge-pathnames (make-pathname :type "lock")
                                                            context-designator)))
Eric Timmons's avatar
Eric Timmons committed
147
148
149
    (t
     (error "Unable to translate ~S to a context object" context-designator))))

150
151
152
153
154
(defun context-sources (context)
  (list* (context-fs-source context)
         (context-vcs-source context)
         (context-user-sources context)))

155
156
157
158
159
160
161
162
(defun make-vcs-override-fun (root-pathname)
  (let ((root-pathname (uiop:pathname-directory-pathname root-pathname)))
    (lambda (project-name)
      (let ((override (config-value :bundle :local project-name)))
        (when override
          (merge-pathnames override root-pathname))))))

(defun call-with-context (thunk context-designator)
163
  (if (context-anonymous-p context-designator)
164
      (let* ((context-name (context-name context-designator))
165
166
167
168
169
170
             (*default-pathname-defaults* (uiop:pathname-directory-pathname context-name))
             (*vcs-project-override-fun* (make-vcs-override-fun *default-pathname-defaults*)))
        (with-config-source (:pathname (merge-pathnames ".clpm/bundle.conf"
                                                        (uiop:pathname-directory-pathname context-name)))
          (funcall thunk (get-context context-designator))))
      (funcall thunk (get-context context-designator))))
171
172
173
174

(defmacro with-context ((context-var &optional (context-value context-var)) &body body)
  `(call-with-context (lambda (,context-var) ,@body) ,context-value))

Eric Timmons's avatar
Eric Timmons committed
175
176
177
178
179

;; * Adding requirements

(defun context-find-requirement (context type name)
  (find-if (lambda (req)
180
181
182
             (and (ecase type
                    (:project (or (typep req 'project-requirement)
                                  (typep req 'vcs-project-requirement)))
183
                    (:system (typep req 'system-requirement))
184
185
                    (:asd-system (typep req 'fs-system-requirement))
                    (:asd-file (typep req 'fs-system-file-requirement)))
186
                  (equal name (requirement-name req))))
Eric Timmons's avatar
Eric Timmons committed
187
188
189
           (context-requirements context)))

(defun context-add-requirement! (context req)
190
191
192
  "If the requirement is new, add it. Otherwise modify an existing requirement
in place with the same name. Return the new requirement if it was modified."
  (let ((existing-req (context-find-requirement context (requirement-type-keyword req)
193
                                                (requirement-name req))))
194
195
196
197
    (when (typep req 'fs-system-file-requirement)
      (fs-source-register-asd (context-fs-source context) (requirement-name req)))
    (when (typep req 'fs-system-requirement)
      (fs-source-register-asd (context-fs-source context) (requirement-pathname req)))
Eric Timmons's avatar
Eric Timmons committed
198
    (if existing-req
199
200
201
202
203
204
205
206
207
        (progn
          (log:debug "Replacing requirement ~A with ~A" existing-req req)
          (setf (context-requirements context)
                (substitute req existing-req (context-requirements context)))
          req)
        (progn
          (log:debug "Adding requirement ~A" req)
          (push req (context-requirements context))
          nil))))
Eric Timmons's avatar
Eric Timmons committed
208

Eric Timmons's avatar
Eric Timmons committed
209
210
211

;; * ASDF Integration

212
(defun context-asd-pathnames (context)
213
214
  (let* ((context (get-context context))
         (releases (context-releases context))
215
216
217
         (system-files (flatten (mapcar #'release-system-files releases))))
    (mapcar #'system-file-absolute-asd-pathname system-files)))

218
219
220
221
222
223
224
225
226
227
(defun context-editable-primary-system-names (context)
  (let* ((releases (context-releases context))
         (editable-releases (remove-if-not (lambda (x) (eql x (context-fs-source context)))
                                           releases
                                           :key #'release-source))
         (editable-system-files (mapcan #'release-system-files editable-releases)))
    (sort (remove-duplicates (mapcar #'system-file-primary-system-name editable-system-files)
                        :test #'equal)
          #'string<)))

228
229
230
231
232
233
234
(defun context-installed-primary-system-names (context)
  (let* ((context (get-context context))
         (system-releases (context-system-releases context)))
    (remove-duplicates
     (mapcar (compose #'asdf:primary-system-name #'system-name #'system-release-system) system-releases)
     :test #'equal)))

Eric Timmons's avatar
Eric Timmons committed
235
236
237
238
239
(defun context-installed-systems (context)
  (let* ((context (get-context context))
         (system-releases (context-system-releases context)))
    (mapcar #'system-release-system system-releases)))

Eric Timmons's avatar
Eric Timmons committed
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
(defun context-visible-primary-system-names (context)
  (let* ((context (get-context context))
         (releases (context-releases context))
         (system-releases (context-system-releases context))
         (system-files (remove-duplicates (mapcar #'system-release-system-file system-releases)))
         (system-file-directories (remove-duplicates (mapcar (compose #'uiop:pathname-directory-pathname
                                                                      #'system-file-absolute-asd-pathname)
                                                             system-files)
                                                     :test #'uiop:pathname-equal))
         (all-system-files (mappend #'release-system-files releases))
         (visible-system-files (remove-if-not (lambda (sf)
                                                (member (uiop:pathname-directory-pathname
                                                         (system-file-absolute-asd-pathname sf))
                                                        system-file-directories
                                                        :test #'uiop:pathname-equal))
                                              all-system-files)))
    (mapcar #'system-file-primary-system-name visible-system-files)))

258
(defun context-to-asdf-source-registry.d-forms (context)
259
260
  (let* ((context (get-context context))
         (system-file-pathnames (context-asd-pathnames context))
Eric Timmons's avatar
Eric Timmons committed
261
262
         (system-file-directories (remove-duplicates (mapcar #'uiop:pathname-directory-pathname system-file-pathnames)
                                                     :test #'uiop:pathname-equal)))
263
264
    (mapcar (lambda (x) (list :directory x)) system-file-directories)))

265
266
267
268
(defun context-to-asdf-source-registry-form (context &key extra-forms
                                                       ignore-inherited
                                                       splice-inherited
                                                       with-client)
269
  `(:source-registry
270
    ,@(context-to-asdf-source-registry.d-forms context)
271
272
273
274
275
276
277
278
279
280
281
282
    ,@(when with-client
        `((:directory ,(uiop:pathname-directory-pathname (client-asd-pathname)))))
    ,@extra-forms
    ,@(cond
        (ignore-inherited
         (list :ignore-inherited-configuration))
        ((and (stringp splice-inherited) (not (equal splice-inherited "")))
         (rest (asdf/source-registry:parse-source-registry-string splice-inherited)))
        ((and splice-inherited (listp splice-inherited))
         (rest splice-inherited))
        (t
         (list :inherit-configuration)))))
283

284
285
286
287
288
289
290
(defun context-find-system-asd-pathname (context system-name)
  (when-let* ((context (get-context context))
              (system-release (find system-name (context-system-releases context)
                                    :key (compose #'system-name #'system-release-system)
                                    :test #'equal)))
    (system-release-absolute-asd-pathname system-release)))

291
(defun context-write-asdf-files (context)
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
  (unless (context-anonymous-p context)
    (let* ((name (context-name context))
           (source-registry-files (config-value :contexts name :source-registry-files))
           (source-registry.d-files (config-value :contexts name :source-registry.d-files))
           (registry-form (context-to-asdf-source-registry-form context))
           (registry.d-forms (context-to-asdf-source-registry.d-forms context)))
      (uiop:with-safe-io-syntax ()
        (let ((*print-case* :downcase))
          (dolist (f source-registry-files)
            (log:debug "Writing context source-registry file to ~A" f)
            (ensure-directories-exist f)
            (with-open-file (s f :direction :output :if-exists :supersede)
              (write-string ";; -*- mode: common-lisp; -*-" s)
              (terpri s)
              (write-string ";; Autogenerated by clpm. Do not edit directly." s)
              (terpri s)
              (prin1 registry-form s)
              (terpri s)))
          (dolist (f source-registry.d-files)
            (log:debug "Writing context source-registry.d file to ~A" f)
            (ensure-directories-exist f)
            (with-open-file (s f :direction :output :if-exists :supersede)
              (write-string ";; -*- mode: common-lisp; -*-" s)
              (terpri s)
              (write-string ";; Autogenerated by clpm. Do not edit directly." s)
              (terpri s)
              (dolist (form registry.d-forms)
                (prin1 form s)
                (terpri s)))))))))
Eric Timmons's avatar
Eric Timmons committed
321

Eric Timmons's avatar
Eric Timmons committed
322
(defun context-output-translations (context)
Eric Timmons's avatar
Eric Timmons committed
323
324
325
326
327
328
329
330
331
  (if (context-anonymous-p context)
      (let ((pathname (context-name context)))
        (case (config-value :bundle :output-translation)
          ((t)
           `(:output-translations
             :ignore-inherited-configuration
             (t (:root ,@(rest (pathname-directory (clpm-cache-pathname '("bundle" "fasl-cache")
                                                                        :ensure-directory t)))
                       ,(urlencode (format nil "~{~A~^/~}" (rest (pathname-directory pathname))))
332
                       :implementation :**/ :*.*.*))))
Eric Timmons's avatar
Eric Timmons committed
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
          (:local
           `(:output-translations
             :ignore-inherited-configuration
             (t (,(uiop:pathname-directory-pathname pathname) ".clpm" "fasl-cache"
                 :implementation :**/ :*.*.*))))
          (t
           nil)))
      (let* ((context (get-context context))
             (name (context-name context))
             (config-value (config-value :contexts name :output-translation)))
        (when config-value
          `(:output-translations
            :ignore-inherited-configuration
            (t (:root ,@(rest (pathname-directory (clpm-cache-pathname `("contexts" ,name "fasl-cache")
                                                                       :ensure-directory t)))
                :implementation :**/ :*.*.*)))))))
Eric Timmons's avatar
Eric Timmons committed
349
350
351
352


;; * Deserializing

353
(defun load-anonymous-context-from-pathname (pn)
354
355
356
357
358
  (if (probe-file pn)
      (with-open-file (s pn)
        (load-context-from-stream s pn))
      (make-instance 'context
                     :name pn)))
359
360
361
362
363
364
365

(defun context-downselect-sources (name sources)
  (let ((allowed-source-names (config-value :contexts name :sources)))
    (if (eql t allowed-source-names)
        sources
        (remove-if-not (lambda (x) (member (source-name x) allowed-source-names :test 'equal))
                       sources))))
Eric Timmons's avatar
Eric Timmons committed
366

Eric Timmons's avatar
Eric Timmons committed
367
(defun load-global-context (name &optional (error t))
368
369
  ;; Global contexts can have their sources downselected by the user config. We
  ;; accomplish this by setting the sources for the context after it has loaded.
Eric Timmons's avatar
Eric Timmons committed
370
371
372
373
  (let ((pn (global-context-pathname name)))
    (with-open-file (s pn
                       :if-does-not-exist (if error :error nil))
      (if s
374
375
          (aprog1 (load-context-from-stream s name)
            (setf (context-user-sources it) (context-downselect-sources name (sources))))
Eric Timmons's avatar
Eric Timmons committed
376
377
          (make-instance 'context
                         :name name
378
                         :user-sources (context-downselect-sources name (sources)))))))
Eric Timmons's avatar
Eric Timmons committed
379
380
381
382

(defgeneric check-section-valid (prev-section current-section)
  (:method (prev-section current-section)
    (error "Invalid section transition ~S -> ~S" prev-section current-section))
Eric Timmons's avatar
Eric Timmons committed
383
384
385
  (:method ((prev-section (eql nil)) (current-section (eql :sources)))
    t)
  (:method ((prev-section (eql :sources)) (current-section (eql :requirements)))
Eric Timmons's avatar
Eric Timmons committed
386
387
388
389
390
391
392
393
394
    t)
  (:method ((prev-section (eql :requirements)) (current-section (eql :releases)))
    t)
  (:method ((prev-section (eql :releases)) (current-section (eql :reverse-dependencies)))
    t))

(defgeneric process-form (context section form))

(defmethod process-form (context (section (eql :requirements)) form)
395
  (destructuring-bind (type &key name version source branch tag commit ref pathname no-deps-p) form
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
    (context-add-requirement! context
                              (cond
                                ((eql type :asd-system)
                                 (make-instance 'fs-system-requirement
                                                :name name
                                                :pathname pathname
                                                :no-deps-p no-deps-p
                                                :why t))
                                ((eql type :asd-file)
                                 (make-instance 'fs-system-file-requirement
                                                :name name
                                                :no-deps-p no-deps-p
                                                :why t))
                                ((or branch tag commit ref)
                                 (make-instance 'vcs-project-requirement
                                                :name name
                                                :source (get-source source)
                                                :commit commit
                                                :branch branch
                                                :tag tag
                                                :ref ref
                                                :no-deps-p no-deps-p
                                                :why t))
                                (t
                                 (make-instance (ecase type
                                                  (:system 'system-requirement)
                                                  (:project 'project-requirement))
                                                :name name
                                                :source (get-source source)
                                                :version-spec version
                                                :no-deps-p no-deps-p
                                                :why t))))))
Eric Timmons's avatar
Eric Timmons committed
428

429
430
(defmethod process-form (context (section (eql :releases)) form)
  (destructuring-bind (name &key version source systems) form
Eric Timmons's avatar
Eric Timmons committed
431
432
433
434
435
436
437
    (let* ((source (get-source source))
           (release (source-project-release source name version)))
      (push release
            (context-releases context))
      (dolist (system-name systems)
        (push (release-system-release release system-name)
              (context-system-releases context))))))
Eric Timmons's avatar
Eric Timmons committed
438
439
440

(defmethod process-form (context (section (eql :reverse-dependencies)) form))

Eric Timmons's avatar
Eric Timmons committed
441
(defmethod process-form (context (section (eql :sources)) form)
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
  (case (first form)
    (:implicit-vcs
     (dolist (project-description (getf (rest form) :projects))
       (vcs-source-register-project! (context-vcs-source context)
                                     (make-repo-from-description (rest project-description))
                                     (first project-description))))
    (:implicit-file
     (dolist (sf (getf (rest form) :system-files))
       (fs-source-register-asd (context-fs-source context) sf)))
    (t
     (let ((source (load-source-from-form form)))
       (unless (or (source-can-lazy-sync-p source)
                   (config-value :local))
         (sync-source source))
       (setf (context-user-sources context) (append (context-user-sources context) (list source)))))))
Eric Timmons's avatar
Eric Timmons committed
457

458
(defun load-context-from-stream (stream name)
Eric Timmons's avatar
Eric Timmons committed
459
460
461
462
463
  (uiop:with-safe-io-syntax ()
    ;; The first form in the stream must be an API declaration.
    (let ((f (read stream nil)))
      (unless (equal f '(:api-version "0.3"))
        (error "Unknown context API version")))
464
465
    (let ((out (make-instance 'context
                              :name name)))
Eric Timmons's avatar
Eric Timmons committed
466
467
468
469
470
471
472
473
474
      ;; The next forms are either tags or lists. The tags denote sections.
      (loop
        :with section := nil
        :for form := (read stream nil :eof)
        :until (eql form :eof)
        :when (symbolp form)
          :do (check-section-valid section form)
              (setf section form)
        :else
475
476
          :do (with-sources ((context-sources out))
                (process-form out section form)))
Eric Timmons's avatar
Eric Timmons committed
477
      out)))
Eric Timmons's avatar
Eric Timmons committed
478
479
480
481


;; * Serializing

482
(defun save-context (context)
Eric Timmons's avatar
Eric Timmons committed
483
  (assert (context-reverse-dependencies context))
484
  (let ((pn (if (context-anonymous-p context)
485
                (merge-pathnames (make-pathname :type "lock") (context-name context))
486
                (global-context-pathname (context-name context)))))
Eric Timmons's avatar
Eric Timmons committed
487
488
489
490
491
492
    (ensure-directories-exist pn)
    (with-open-file (s pn
                       :direction :output
                       :if-exists :supersede)
      (serialize-context-to-stream context s))))

Eric Timmons's avatar
Eric Timmons committed
493
494
;; ** Context

Eric Timmons's avatar
Eric Timmons committed
495
496
(defun write-header (text stream)
  (assert (not (position #\Newline text)))
Eric Timmons's avatar
Eric Timmons committed
497
498
499
  (dotimes (i 80)
    (write-char #\; stream))
  (terpri stream)
Eric Timmons's avatar
Eric Timmons committed
500
501
  (write-string ";; " stream)
  (write-string text stream)
Eric Timmons's avatar
Eric Timmons committed
502
503
504
505
506
507
  (terpri stream)
  (dotimes (i 80)
    (write-char #\; stream))
  (terpri stream)
  (terpri stream))

Eric Timmons's avatar
Eric Timmons committed
508
509
510
(defun write-section-header (section-name stream)
  (write-header (concatenate 'string "BEGIN " (string-upcase section-name)) stream))

Eric Timmons's avatar
Eric Timmons committed
511
512
513
514
515
516
517
(defun serialize-context-to-stream (context stream)
  (uiop:with-safe-io-syntax ()
    (let ((*print-case* :downcase)
          (*print-length* nil)
          (*print-level* nil)
          (*print-pretty* t)
          (*print-right-margin* nil))
Eric Timmons's avatar
Eric Timmons committed
518
      (write-header "This is autogenerated by CLPM. Do not edit by hand." stream)
Eric Timmons's avatar
Eric Timmons committed
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
      (format stream "~S~%~%" '(:api-version "0.3"))

      ;; Sources
      (write-section-header "sources" stream)
      (format stream ":sources~%")
      (dolist (source (context-sources context))
        (format stream "~S~%" (source-to-form source)))
      (terpri stream)
      (terpri stream)

      ;; Requirements
      (write-section-header "requirements" stream)
      (format stream ":requirements~%")
      (dolist (req (context-requirements context))
        (format stream "~S~%" (list* (requirement-type-keyword req)
                                     (requirement-to-plist req))))
      (terpri stream)
      (terpri stream)

      ;; Releases
      (write-section-header "releases" stream)
      (format stream ":releases~%")
      (dolist (release (sort (copy-list (context-releases context)) #'string<
                             :key (compose #'project-name #'release-project)))
543
544
545
546
547
        (format stream "~S~%"
                (context-release-to-form release (remove-if-not (lambda (x)
                                                                  (eql x release))
                                                                (context-system-releases context)
                                                                :key #'system-release-release))))
Eric Timmons's avatar
Eric Timmons committed
548
549
550
551
552
553
554
555
556
      (terpri stream)
      (terpri stream)

      ;; Reverse Dependencies
      (write-section-header "reverse-dependencies" stream)
      (format stream ":reverse-dependencies~%")
      (dolist (reverse-dep (sort (copy-list (context-reverse-dependencies context)) #'string<
                                 :key (compose #'project-name #'release-project #'car)))
        (format stream "~S~%~%" (context-reverse-deps-to-form reverse-dep))))))
Eric Timmons's avatar
Eric Timmons committed
557

Eric Timmons's avatar
Eric Timmons committed
558
559
560
;; ** Releases

(defmethod extract-why ((why clpm-system-release))
561
  (let* ((system (system-release-system why)))
Eric Timmons's avatar
Eric Timmons committed
562
    (list :system :name (system-name system))))
Eric Timmons's avatar
Eric Timmons committed
563
564
565
566

(defmethod extract-why ((why (eql t)))
  t)

Eric Timmons's avatar
Eric Timmons committed
567
(defun reverse-dep-to-form (req)
568
  (let ((why (requirement-why req)))
Eric Timmons's avatar
Eric Timmons committed
569
570
571
572
573
574
575
576
577
578
579
    `(,(extract-why why)
      ,(list* (requirement-type-keyword req)
              (requirement-to-plist req)))))

(defun context-release-to-form (release system-releases)
  `(,(project-name (release-project release))
    :version ,(release-version release)
    :source ,(source-name (release-source release))
    :systems ,(mapcar (compose #'system-name #'system-release-system) system-releases)))

(defun context-reverse-deps-to-form (release-and-reverse-deps)
Eric Timmons's avatar
Eric Timmons committed
580
  (destructuring-bind (release . reverse-deps) release-and-reverse-deps
Eric Timmons's avatar
Eric Timmons committed
581
582
583
584
585
586
    ;; Filter out the requirements where we didn't know the true reason for the
    ;; requirement at the time (likely because we were trying to load an ASD
    ;; file into the groveler). We can ignore it because we *should* have the
    ;; true reason elsewhere in the list.
    (setf reverse-deps (remove :grovel (remove t reverse-deps)
                               :key #'requirement-why))
Eric Timmons's avatar
Eric Timmons committed
587
588
589
590
591
592
593
594
595
596
597
598
    (let ((project (release-project release))
          reverse-dep-forms)
      (dolist (reverse-dep (sort (copy-list reverse-deps)
                                 (lambda (x y)
                                   (cond
                                     ((eql x t) t)
                                     ((eql y t) nil)
                                     (t (string< (system-name (system-release-system x))
                                                 (system-name (system-release-system y))))))
                                 :key #'requirement-why))
        (push (reverse-dep-to-form reverse-dep) reverse-dep-forms))
      `(,(project-name project) ,@reverse-dep-forms))))
Eric Timmons's avatar
Eric Timmons committed
599
600
601
602
603

;; ** Requirements

(defgeneric requirement-type-keyword (req))

Eric Timmons's avatar
Eric Timmons committed
604
605
606
(defmethod requirement-type-keyword ((req project-requirement))
  :project)

Eric Timmons's avatar
Eric Timmons committed
607
608
609
(defmethod requirement-type-keyword ((req system-requirement))
  :system)

Eric Timmons's avatar
Eric Timmons committed
610
(defmethod requirement-type-keyword ((req fs-system-requirement))
Eric Timmons's avatar
Eric Timmons committed
611
  :asd-system)
Eric Timmons's avatar
Eric Timmons committed
612

613
614
615
(defmethod requirement-type-keyword ((req fs-system-file-requirement))
  :asd-file)

616
617
(defmethod requirement-type-keyword ((req vcs-project-requirement))
  :project)