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

Delay resolving system-release objects when loading contexts

parent dad72e48
Loading
Loading
Loading
Loading
+5 −4
Original line number Original line Diff line number Diff line
@@ -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
+7 −4
Original line number Original line Diff line number Diff line
@@ -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)
                                                                     (member missing-system-name x :test #'equal))
                                                                   (context-system-releases clpmfile)
                                                                   (context-system-releases clpmfile)
                                                              :test #'equal
                                                                   :key #'cdr))
                                                              :key (compose #'system-name #'system-release-system))))
                                           (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
+27 −16
Original line number Original line Diff line number Diff line
@@ -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."))
                 :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."
  (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."


(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."
      (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."
      (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."
      ,(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
+4 −1
Original line number Original line Diff line number Diff line
@@ -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)))
+5 −4
Original line number Original line Diff line number Diff line
@@ -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)))