Commit c5023bf1 authored by Eric Timmons's avatar Eric Timmons
Browse files

Simplify printing of contexts

It was a fun and enlightening experiment to use the pretty printer for
printing contexts, but it's ultimately unnecessary and just makes the code more
difficult to read.

If we want to go back to the pretty printer in the future, I think it's
ultimately better to rebind the pprint dispatch table and add new dispatches
for the types of things that are being printed.
parent ee8f0b89
......@@ -417,80 +417,45 @@ in place with the same name. Return the new requirement if it was modified."
(*print-pretty* t)
(*print-right-margin* nil))
(write-header "This is autogenerated by CLPM. Do not edit by hand." stream)
(pprint-logical-block (stream nil)
(prin1 '(:api-version "0.3") stream)
(pprint-newline :mandatory stream)
(pprint-newline :mandatory stream)
;; Streams
(write-section-header "sources" stream)
(prin1 :sources stream)
(pprint-newline :mandatory stream)
(pprint-logical-block (stream (context-sources context))
(pprint-exit-if-list-exhausted)
(loop
(serialize-context-source (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream)))
(pprint-newline :mandatory stream)
(pprint-newline :mandatory stream)
;; Requirements
(write-section-header "requirements" stream)
(prin1 :requirements stream)
(pprint-newline :mandatory stream)
(pprint-logical-block (stream (context-requirements context))
(pprint-exit-if-list-exhausted)
(loop
(serialize-context-requirement (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream)))
(pprint-newline :mandatory stream)
(pprint-newline :mandatory stream)
;; Releases
(write-section-header "releases" stream)
(prin1 :releases stream)
(pprint-newline :mandatory stream)
(pprint-logical-block (stream (sort (copy-list (context-releases context)) #'string<
:key (compose #'project-name #'release-project)))
(pprint-exit-if-list-exhausted)
(loop
(let ((release (pprint-pop)))
(unless (typep release 'fs-release)
(serialize-context-release release
(remove-if-not (lambda (x)
(eql x release))
(context-system-releases context)
:key #'system-release-release)
stream))
(pprint-exit-if-list-exhausted)
(unless (typep release 'fs-release)
(pprint-newline :mandatory stream)))))
(pprint-newline :mandatory stream)
(pprint-newline :mandatory stream)
;; Reverse Dependencies
(write-section-header "reverse-dependencies" stream)
(prin1 :reverse-dependencies stream)
(pprint-newline :mandatory stream)
(pprint-logical-block (stream (sort (copy-list (context-reverse-dependencies context)) #'string<
:key (compose #'project-name #'release-project #'car)))
(pprint-exit-if-list-exhausted)
(loop
(let ((release-and-reverse-deps (pprint-pop)))
(serialize-context-reverse-dependencies
release-and-reverse-deps
stream))
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream)
(pprint-newline :mandatory stream)))
(pprint-newline :mandatory stream)))))
;; ** Sources
(defun serialize-context-source (source stream)
(prin1 (source-to-form source) stream))
(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)))
(unless (typep release 'fs-release)
(format stream "~S~%"
(context-release-to-form release (remove-if-not (lambda (x)
(eql x release))
(context-system-releases context)
:key #'system-release-release)))))
(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))))))
;; ** Releases
......@@ -501,45 +466,19 @@ in place with the same name. Return the new requirement if it was modified."
(defmethod extract-why ((why (eql t)))
t)
(defun serialize-reverse-dep (req stream)
(defun reverse-dep-to-form (req)
(let ((why (requirement-why req)))
(pprint-logical-block (stream nil :prefix "(" :suffix ")")
(prin1 (extract-why why) stream)
(pprint-newline :mandatory stream)
(serialize-context-requirement req stream))))
(defun serialize-context-release (release system-releases stream)
(let ((project (release-project release)))
(pprint-logical-block (stream nil :prefix "(" :suffix ")")
;; Name
(prin1 (project-name project) stream)
;; Version
(pprint-newline :mandatory stream)
(prin1 :version stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (release-version release) stream)
;; Source
(pprint-newline :mandatory stream)
(prin1 :source stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (source-name (release-source release)) stream)
;; Systems
(pprint-newline :mandatory stream)
(prin1 :systems stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(pprint-logical-block (stream system-releases :prefix "(" :suffix ")")
(pprint-exit-if-list-exhausted)
(loop
(prin1 (system-name (system-release-system (pprint-pop))) stream)
(pprint-exit-if-list-exhausted)
(write-char #\Space stream)
(pprint-newline :fill stream))))))
(defun serialize-context-reverse-dependencies (release-and-reverse-deps stream)
`(,(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)
(destructuring-bind (release . reverse-deps) release-and-reverse-deps
;; 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
......@@ -547,34 +486,21 @@ in place with the same name. Return the new requirement if it was modified."
;; true reason elsewhere in the list.
(setf reverse-deps (remove :grovel (remove t reverse-deps)
:key #'requirement-why))
(let ((project (release-project release)))
(pprint-logical-block (stream nil :prefix "(" :suffix ")")
;; Name
(prin1 (project-name project) stream)
;; Reverse deps
(pprint-newline :mandatory stream)
(pprint-logical-block (stream (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))
(pprint-exit-if-list-exhausted)
(loop
(let* ((req (pprint-pop)))
(serialize-reverse-dep req stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream))))))))
(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))))
;; ** Requirements
(defgeneric serialize-context-requirement (req stream))
(defgeneric requirement-type-keyword (req))
(defmethod requirement-type-keyword ((req project-requirement))
......@@ -591,162 +517,3 @@ in place with the same name. Return the new requirement if it was modified."
(defmethod requirement-type-keyword ((req vcs-project-requirement))
:project)
(defmethod serialize-context-requirement ((req vcs-project-requirement) stream)
(pprint-logical-block (stream nil :prefix "(" :suffix ")")
(prin1 (requirement-type-keyword req) stream)
;; Name
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :name stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (requirement-name req) stream)
;; Branch
(when (requirement-branch req)
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :branch stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (requirement-branch req) stream))
;; Commit
(when (requirement-commit req)
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :commit stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (requirement-commit req) stream))
;; Tag
(when (requirement-tag req)
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :tag stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (requirement-tag req) stream))
;; Ref
(when (requirement-ref req)
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :ref stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (requirement-ref req) stream))
;; Source
(when (requirement-source req)
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :source stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (source-name (requirement-source req)) stream))
;; no deps
(when (requirement-no-deps-p req)
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :no-deps-p stream)
(write-char #\Space stream)
(prin1 t stream))))
(defmethod serialize-context-requirement ((req versioned-requirement) stream)
(pprint-logical-block (stream nil :prefix "(" :suffix ")")
(prin1 (requirement-type-keyword req) stream)
;; Name
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :name stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (requirement-name req) stream)
;; Version
(when (requirement-version-spec req)
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :version stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (requirement-version-spec req) stream))
;; Source
(when (requirement-source req)
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :source stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (source-name (requirement-source req)) stream))
;; no deps
(when (requirement-no-deps-p req)
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :no-deps-p stream)
(write-char #\Space stream)
(prin1 t stream))))
(defmethod serialize-context-requirement ((req fs-system-requirement) stream)
(pprint-logical-block (stream nil :prefix "(" :suffix ")")
(prin1 (requirement-type-keyword req) stream)
;; pathname
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :pathname stream)
(write-char #\Space stream)
(prin1 (requirement-pathname req) stream)
;; Name
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :name stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(prin1 (requirement-name req) stream)
;; no deps
(when (requirement-no-deps-p req)
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :no-deps-p stream)
(write-char #\Space stream)
(prin1 t stream))))
(defmethod serialize-context-requirement ((req fs-system-file-requirement) stream)
(pprint-logical-block (stream nil :prefix "(" :suffix ")")
(prin1 (requirement-type-keyword req) stream)
;; pathname
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :pathname stream)
(write-char #\Space stream)
(prin1 (requirement-name req) stream)
;; no deps
(when (requirement-no-deps-p req)
(write-char #\Space stream)
(pprint-newline :fill stream)
(prin1 :no-deps-p stream)
(write-char #\Space stream)
(prin1 t stream))))
(defmethod print-object ((context context) stream)
(pprint-logical-block (stream nil)
(print-unreadable-object (context stream :type t :identity t)
(pprint-newline :mandatory stream)
;; Sources
(prin1 :sources stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(write (context-sources context) :stream stream)
;; Requirements
(write-char #\Space stream)
(pprint-newline :mandatory stream)
(prin1 :requirements stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(write (context-requirements context) :stream stream)
;; Releases
(write-char #\Space stream)
(pprint-newline :mandatory stream)
(prin1 :releases stream)
(write-char #\Space stream)
(pprint-newline :miser stream)
(write (context-releases context) :stream stream)
;; Put ID on a new line
(pprint-newline :mandatory stream))))
......@@ -5,7 +5,8 @@
;;;; LICENSE for license information.
(uiop:define-package #:clpm/requirement
(:use #:cl)
(:use #:cl
#:anaphora)
(:export #:convert-asd-system-spec-to-req
#:fs-system-file-requirement
#:fs-system-requirement
......@@ -21,6 +22,7 @@
#:requirement-systems
#:requirement-system-files
#:requirement-tag
#:requirement-to-plist
#:requirement-version-spec
#:requirement-why
#:system-requirement
......@@ -199,3 +201,44 @@ represents."))
:why why))
(:feature
(convert-asd-system-spec-to-req (third dep) :why why))))
(defgeneric requirement-to-plist (req))
(defmethod requirement-to-plist ((req versioned-requirement))
(append
(list :name (requirement-name req))
(awhen (requirement-version-spec req)
(list :version it))
(awhen (requirement-source req)
(list :source it))
(awhen (requirement-no-deps-p req)
(list :no-deps-p it))))
(defmethod requirement-to-plist ((req vcs-project-requirement))
(append
(list :name (requirement-name req))
(awhen (requirement-branch req)
(list :branch it))
(awhen (requirement-commit req)
(list :commit it))
(awhen (requirement-tag req)
(list :tag it))
(awhen (requirement-ref req)
(list :ref it))
(awhen (requirement-source req)
(list :source it))
(awhen (requirement-no-deps-p req)
(list :no-deps-p it))))
(defmethod requirement-to-plist ((req fs-system-requirement))
(append
(list :pathname (requirement-pathname req)
:name (requirement-name req))
(awhen (requirement-no-deps-p req)
(list :no-deps-p it))))
(defmethod requirement-to-plist ((req fs-system-file-requirement))
(append
(list :pathname (requirement-pathname req))
(awhen (requirement-no-deps-p req)
(list :no-deps-p it))))
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