Commit 79c65603 authored by Eric Timmons's avatar Eric Timmons
Browse files

Delay resolving system-release objects when loading contexts

parent dad72e48
...@@ -85,10 +85,11 @@ the lock file if necessary." ...@@ -85,10 +85,11 @@ the lock file if necessary."
(sync-source s)))) (sync-source s))))
;; Map all update systems to their projects. ;; Map all update systems to their projects.
(dolist (system update-systems) (dolist (system update-systems)
(when-let* ((system-release (find system (context-system-releases lockfile) (when-let* ((release-cons (find-if (lambda (x)
:key (compose #'system-name #'system-release-system) (member system x :test #'equal))
:test #'equal)) (context-system-releases lockfile)
(release (system-release-release system-release)) :key #'cdr))
(release (car release-cons))
(project-name (project-name (release-project release)))) (project-name (project-name (release-project release))))
(pushnew project-name update-projects :test #'equal))) (pushnew project-name update-projects :test #'equal)))
;; Nuke the lockfile's requirements so that we pick up deletions ;; Nuke the lockfile's requirements so that we pick up deletions
......
...@@ -76,10 +76,13 @@ ...@@ -76,10 +76,13 @@
(let* ((missing-system-spec (groveler-dependency-missing-system c)) (let* ((missing-system-spec (groveler-dependency-missing-system c))
(missing-req (convert-asd-system-spec-to-req missing-system-spec)) (missing-req (convert-asd-system-spec-to-req missing-system-spec))
(missing-system-name (requirement-name missing-req)) (missing-system-name (requirement-name missing-req))
(matching-sr (find missing-system-name (matching-cons (find-if (lambda (x)
(context-system-releases clpmfile) (member missing-system-name x :test #'equal))
:test #'equal (context-system-releases clpmfile)
:key (compose #'system-name #'system-release-system)))) :key #'cdr))
(matching-sr (when matching-cons
(release-system-release (car matching-cons)
missing-system-name))))
(when (and matching-sr (when (and matching-sr
(system-release-satisfies-version-spec-p (system-release-satisfies-version-spec-p
matching-sr matching-sr
......
...@@ -83,7 +83,12 @@ pathname (if this is an anonymous context).") ...@@ -83,7 +83,12 @@ pathname (if this is an anonymous context).")
(system-releases (system-releases
:initform nil :initform nil
:initarg :system-releases :initarg :system-releases
:accessor context-system-releases)) :accessor context-system-releases
:documentation
"An alist mapping release objects to strings naming the systems installed as
part of the release. SYSTEM-RELEASE objects must *not* be used here, because
they are not guaranteed to be constructable when the context is read (e.g.,
in the case of VCS repos where commits have been deleted)."))
(:documentation (:documentation
"Represents a snapshot of a context. Includes sources, the releases installed "Represents a snapshot of a context. Includes sources, the releases installed
in the context, the requirements that gave rise to those releases, etc. Contexts in the context, the requirements that gave rise to those releases, etc. Contexts
...@@ -128,7 +133,7 @@ can be named, global contexts, or anonymous.")) ...@@ -128,7 +133,7 @@ can be named, global contexts, or anonymous."))
:requirements (copy-list (context-requirements context)) :requirements (copy-list (context-requirements context))
:reverse-dependencies (copy-alist (context-reverse-dependencies context)) :reverse-dependencies (copy-alist (context-reverse-dependencies context))
:user-sources (copy-list (context-user-sources context)) :user-sources (copy-list (context-user-sources context))
:system-releases (copy-list (context-system-releases context)))) :system-releases (copy-tree (context-system-releases context))))
(defun global-context-pathname (name) (defun global-context-pathname (name)
(clpm-data-pathname (list "contexts" name))) (clpm-data-pathname (list "contexts" name)))
...@@ -229,18 +234,24 @@ in place with the same name. Return the new requirement if it was modified." ...@@ -229,18 +234,24 @@ in place with the same name. Return the new requirement if it was modified."
(let* ((context (get-context context)) (let* ((context (get-context context))
(system-releases (context-system-releases context))) (system-releases (context-system-releases context)))
(remove-duplicates (remove-duplicates
(mapcar (compose #'asdf:primary-system-name #'system-name #'system-release-system) system-releases) (mappend (lambda (x) (mapcar #'asdf:primary-system-name (cdr x)))
system-releases)
:test #'equal))) :test #'equal)))
(defun context-installed-systems (context) (defun context-installed-systems (context)
(let* ((context (get-context context)) (let* ((context (get-context context))
(system-releases (context-system-releases context))) (system-releases (context-system-releases context)))
(mapcar #'system-release-system system-releases))) (mappend #'cdr system-releases)))
(defun context-visible-primary-system-names (context) (defun context-visible-primary-system-names (context)
(let* ((context (get-context context)) (let* ((context (get-context context))
(releases (context-releases context)) (releases (context-releases context))
(system-releases (context-system-releases context)) (system-release-alist (context-system-releases context))
(system-releases (mappend (lambda (x)
(mapcar (lambda (system-name)
(release-system-release (car x) system-name))
(cdr x)))
system-release-alist))
(system-files (remove-duplicates (mapcar #'system-release-system-file system-releases))) (system-files (remove-duplicates (mapcar #'system-release-system-file system-releases)))
(system-file-directories (remove-duplicates (mapcar (compose #'uiop:pathname-directory-pathname (system-file-directories (remove-duplicates (mapcar (compose #'uiop:pathname-directory-pathname
#'system-file-absolute-asd-pathname) #'system-file-absolute-asd-pathname)
...@@ -283,9 +294,11 @@ in place with the same name. Return the new requirement if it was modified." ...@@ -283,9 +294,11 @@ in place with the same name. Return the new requirement if it was modified."
(defun context-find-system-asd-pathname (context system-name) (defun context-find-system-asd-pathname (context system-name)
(when-let* ((context (get-context context)) (when-let* ((context (get-context context))
(system-release (find system-name (context-system-releases context) (system-release-cons (find-if (lambda (x)
:key (compose #'system-name #'system-release-system) (member system-name x :test 'equal))
:test #'equal))) (context-system-releases context)
:key #'cdr))
(system-release (release-system-release (car system-release-cons) system-name)))
(system-release-absolute-asd-pathname system-release))) (system-release-absolute-asd-pathname system-release)))
(defun context-write-asdf-files (context) (defun context-write-asdf-files (context)
...@@ -433,8 +446,8 @@ in place with the same name. Return the new requirement if it was modified." ...@@ -433,8 +446,8 @@ in place with the same name. Return the new requirement if it was modified."
(push release (push release
(context-releases context)) (context-releases context))
(dolist (system-name systems) (dolist (system-name systems)
(push (release-system-release release system-name) (push system-name
(context-system-releases context)))))) (assoc-value (context-system-releases context) release))))))
(defmethod process-form (context (section (eql :reverse-dependencies)) form)) (defmethod process-form (context (section (eql :reverse-dependencies)) form))
...@@ -541,10 +554,8 @@ in place with the same name. Return the new requirement if it was modified." ...@@ -541,10 +554,8 @@ in place with the same name. Return the new requirement if it was modified."
(dolist (release (sort (copy-list (context-releases context)) #'string< (dolist (release (sort (copy-list (context-releases context)) #'string<
:key (compose #'project-name #'release-project))) :key (compose #'project-name #'release-project)))
(format stream "~S~%" (format stream "~S~%"
(context-release-to-form release (remove-if-not (lambda (x) (context-release-to-form release (assoc-value (context-system-releases context)
(eql x release)) release))))
(context-system-releases context)
:key #'system-release-release))))
(terpri stream) (terpri stream)
(terpri stream) (terpri stream)
...@@ -570,11 +581,11 @@ in place with the same name. Return the new requirement if it was modified." ...@@ -570,11 +581,11 @@ in place with the same name. Return the new requirement if it was modified."
,(list* (requirement-type-keyword req) ,(list* (requirement-type-keyword req)
(requirement-to-plist req))))) (requirement-to-plist req)))))
(defun context-release-to-form (release system-releases) (defun context-release-to-form (release system-names)
`(,(project-name (release-project release)) `(,(project-name (release-project release))
:version ,(release-version release) :version ,(release-version release)
:source ,(source-name (release-source release)) :source ,(source-name (release-source release))
:systems ,(mapcar (compose #'system-name #'system-release-system) system-releases))) :systems ,system-names))
(defun context-reverse-deps-to-form (release-and-reverse-deps) (defun context-reverse-deps-to-form (release-and-reverse-deps)
(destructuring-bind (release . reverse-deps) release-and-reverse-deps (destructuring-bind (release . reverse-deps) release-and-reverse-deps
......
...@@ -114,5 +114,8 @@ the requirements." ...@@ -114,5 +114,8 @@ the requirements."
(setf (context-reverse-dependencies out-context) (setf (context-reverse-dependencies out-context)
(sort (copy-alist (node-activated-releases final-node)) (sort (copy-alist (node-activated-releases final-node))
#'string< :key (compose #'project-name #'release-project #'car))) #'string< :key (compose #'project-name #'release-project #'car)))
(setf (context-system-releases out-context) (node-activated-system-releases final-node)) (setf (context-system-releases out-context) nil)
(dolist (sr (node-activated-system-releases final-node))
(push (system-name (system-release-system sr))
(assoc-value (context-system-releases out-context) (system-release-release sr))))
out-context))) out-context)))
...@@ -27,10 +27,11 @@ ...@@ -27,10 +27,11 @@
(with-context (context (copy-context orig-context)) (with-context (context (copy-context orig-context))
;; Map all systems to their corresponding projects. ;; Map all systems to their corresponding projects.
(dolist (system update-systems) (dolist (system update-systems)
(when-let* ((system-release (find system (context-system-releases orig-context) (when-let* ((release-cons (find-if (lambda (x)
:key (compose #'system-name #'system-release-system) (member system x :test #'equal))
:test #'equal)) (context-system-releases orig-context)
(release (system-release-release system-release)) :key #'cdr))
(release (car release-cons))
(project-name (project-name (release-project release)))) (project-name (project-name (release-project release))))
(pushnew project-name update-projects :test #'equal))) (pushnew project-name update-projects :test #'equal)))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment