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

Working toward unifying clpmfile, bundle, and context

parent aba89d0f
......@@ -60,10 +60,7 @@ bound to PN's folder."
`(call-with-bundle-default-pathname-defaults (lambda () ,@body) ,clpmfile-pn))
(defun create-empty-lockfile (clpmfile)
(make-instance 'context
:sources (clpmfile-sources clpmfile)
:requirements (clpmfile-all-requirements clpmfile)
:name (clpmfile-lockfile-pathname clpmfile)))
(copy-context clpmfile))
(defun make-vcs-override-fun (clpmfile-pathname)
(let ((clpmfile-directory (uiop:pathname-directory-pathname clpmfile-pathname)))
......@@ -108,7 +105,7 @@ the lock file if necessary."
(lockfile nil)
(changedp nil))
(unless (config-value :local)
(dolist (s (clpmfile-sources clpmfile))
(dolist (s (context-sources clpmfile))
(unless (source-can-lazy-sync-p s)
(sync-source s))))
(if (probe-file lockfile-pathname)
......@@ -120,7 +117,7 @@ the lock file if necessary."
;; Nuke the lockfile's requirements so that we pick up deletions from the
;; clpmfile.
(setf (context-requirements lockfile) nil)
(setf lockfile (install-requirements (clpmfile-all-requirements clpmfile)
(setf lockfile (install-requirements (context-requirements clpmfile)
:context lockfile
:validate (lambda (diff)
(aprog1 (funcall validate diff)
......@@ -188,7 +185,7 @@ the lock file if necessary."
;; Load the existing lockfile
(setf lockfile (load-lockfile lockfile-pathname))
(unless (config-value :local)
(dolist (s (clpmfile-sources clpmfile))
(dolist (s (context-sources clpmfile))
(unless (source-can-lazy-sync-p s)
(sync-source s))))
;; Map all update systems to their projects.
......@@ -199,7 +196,7 @@ the lock file if necessary."
(release (system-release-release system-release))
(project-name (project-name (release-project release))))
(pushnew project-name update-projects :test #'equal)))
(setf lockfile (install-requirements (clpmfile-all-requirements clpmfile)
(setf lockfile (install-requirements (context-requirements clpmfile)
:context lockfile
:validate (lambda (diff)
(aprog1 (funcall validate diff)
......
......@@ -9,112 +9,31 @@
#:anaphora
#:iterate
#:clpm/config
#:clpm/context
#:clpm/repos
#:clpm/requirement
#:clpm/source
#:clpm/utils)
(:export #:clpmfile-all-requirements
#:clpmfile-lockfile-pathname
(:export #:clpmfile-lockfile-pathname
#:clpmfile-pathname
#:clpmfile-sources
#:clpmfile-user-requirements
#:get-clpmfile
#:read-clpmfile))
#:get-clpmfile))
(in-package #:clpm/clpmfile)
;; * Class Definitions
(defclass clpmfile ()
((pathname
:initarg :pathname
:accessor clpmfile-pathname
:documentation
"The pathname to this file.")
(user-global-sources
:initarg :user-global-sources
:initform nil
:accessor clpmfile-user-global-sources
:documentation
"The sources defined by the user in the clpmfile. A list of source
objects.")
(fs-source
:accessor clpmfile-fs-source
:documentation
"The filesystem source rooted at this clpmfile's directory.")
(user-asd-files
:initarg :user-asd-files
:initform nil
:accessor clpmfile-user-asd-files
:documentation
"The asd files the user has specified in the clpmfile. A list where each
element is `(path-to-asd-file &key systems)`. If `:systems` is nil, the file
is grovelled to find all systems defined within it.")
(user-requirements
:initarg :user-requirements
:initform nil
:accessor clpmfile-user-requirements
:documentation
"A list of requirements specified by the user.")
(vcs-source
:accessor clpmfile-vcs-source
:documentation
"A VCS source to where raw vcs requirements can be homed."))
(:documentation
"Representation of a clpmfile."))
(defmethod initialize-instance :after ((clpmfile clpmfile) &key &allow-other-keys)
"Set the ~clpmfile~'s filesystem source based on the directory where the
clpmfile is located."
(setf (clpmfile-fs-source clpmfile)
(make-source 'fs-source
:root-pathname (uiop:pathname-directory-pathname
(uiop:make-pathname* :directory '(:relative)))
:name :clpmfile-fs))
(setf (clpmfile-vcs-source clpmfile)
(make-source 'vcs-source :name :clpmfile-vcs)))
(defun clpmfile-asd-file-requirements (clpmfile)
"Return a list of requirements gathered from the ~:asd~ statements in
~clpmfile~."
(let ((fs-source (clpmfile-fs-source clpmfile)))
(mapcan (lambda (x)
(destructuring-bind (asd-file &key systems)
x
(if systems
(mapcar (lambda (system-name)
(make-instance 'fs-system-requirement
:name system-name
:source fs-source
:pathname asd-file
:why t))
systems)
(list (make-instance 'fs-system-file-requirement
:source fs-source
:name asd-file
:why t)))))
(clpmfile-user-asd-files clpmfile))))
(defun clpmfile-all-requirements (clpmfile)
"Return a list of all requirements specified by ~clpmfile~."
(append
(clpmfile-asd-file-requirements clpmfile)
(clpmfile-user-requirements clpmfile)))
(defun clpmfile-pathname (clpmfile)
(assert (context-anonymous-p clpmfile))
(context-name clpmfile))
(defun clpmfile-lockfile-pathname (clpmfile)
(merge-pathnames (make-pathname :type "lock")
(clpmfile-pathname clpmfile)))
(defun clpmfile-sources (clpmfile)
"Return a list of all the sources associated with ~clpmfile~."
(list* (clpmfile-fs-source clpmfile)
(clpmfile-vcs-source clpmfile)
(clpmfile-user-global-sources clpmfile)))
(defgeneric get-clpmfile (clpmfile-designator))
(defmethod get-clpmfile ((clpmfile-designator clpmfile))
(defmethod get-clpmfile ((clpmfile-designator context))
clpmfile-designator)
(defmethod get-clpmfile ((clpmfile-designator pathname))
......@@ -144,11 +63,22 @@ source."
(error "The argument to :ASD must be a string"))
(unless (probe-file (merge-pathnames asd-file))
(error "The argument to :ASD must exist"))
;; Register the system with the fs-source
(fs-source-register-asd (clpmfile-fs-source clpmfile)
asd-file)
(push `(,asd-file ,@(when systems (list :systems systems)))
(clpmfile-user-asd-files clpmfile))))
(let ((fs-source (context-vcs-source clpmfile)))
;; Register the system with the fs-source
(fs-source-register-asd fs-source asd-file)
(if systems
(dolist (system-name systems)
(context-add-requirement! clpmfile
(make-instance 'fs-system-requirement
:name system-name
:source fs-source
:pathname asd-file
:why t)))
(context-add-requirement! clpmfile
(make-instance 'fs-system-file-requirement
:source fs-source
:name asd-file
:why t))))))
(defmethod parse-clpmfile-form (clpmfile (type (eql :github)) args)
......@@ -156,7 +86,7 @@ source."
instance."
(destructuring-bind (name &key (host "github.com") path branch commit tag systems)
args
(let ((source (clpmfile-vcs-source clpmfile))
(let ((source (context-vcs-source clpmfile))
(repo (make-repo-from-description (list :github :host host :path path))))
;; Register the git project.
(vcs-source-register-project! source repo name)
......@@ -169,7 +99,7 @@ instance."
:commit commit
:tag tag
:why t)
(clpmfile-user-requirements clpmfile)))))
(context-requirements clpmfile)))))
(defmethod parse-clpmfile-form (clpmfile (type (eql :gitlab)) args)
......@@ -177,7 +107,7 @@ instance."
instance."
(destructuring-bind (name &key (host "gitlab.com") path branch commit tag systems)
args
(let ((source (clpmfile-vcs-source clpmfile))
(let ((source (context-vcs-source clpmfile))
(repo (make-repo-from-description (list :gitlab :host host :path path))))
;; Register the git project.
(vcs-source-register-project! source repo name)
......@@ -190,7 +120,7 @@ instance."
:commit commit
:tag tag
:why t)
(clpmfile-user-requirements clpmfile)))))
(context-requirements clpmfile)))))
(defmethod parse-clpmfile-form (clpmfile (type (eql :project)) args)
(destructuring-bind (name &key source vcs version systems) args
......@@ -200,54 +130,53 @@ instance."
(push (make-instance 'vcs-project-requirement
:name (string-downcase (string name))
:source (when source
(find-source-or-error (clpmfile-user-global-sources clpmfile)
(find-source-or-error (context-user-sources clpmfile)
source))
:branch branch
:commit commit
:tag tag
:systems systems
:why t)
(clpmfile-user-requirements clpmfile)))
(context-requirements clpmfile)))
(push (make-instance 'project-requirement
:name (string-downcase (string name))
:source (when source
(find-source-or-error (clpmfile-user-global-sources clpmfile)
(find-source-or-error (context-user-sources clpmfile)
source))
:version-spec (when version
(cons (first version)
(second version)))
:why t)
(clpmfile-user-requirements clpmfile)))))
(context-requirements clpmfile)))))
(defmethod parse-clpmfile-form (clpmfile (type (eql :source)) args)
"Load a :source statement from a clpmfile and add it to the list of sources."
(unless (stringp (first args))
(error "The first argument to :SOURCE must be a string"))
(push (load-source-from-form args)
(clpmfile-user-global-sources clpmfile)))
(context-user-sources clpmfile)))
(defmethod parse-clpmfile-form (clpmfile (type (eql :system)) args)
"Parse a ~:system~ statement from a ~clpmfile~ into a ~system-requirement~
"Parse a :system statement from a clpmfile into a system-requirement
instance."
(destructuring-bind (name &key source version) args
(push (make-instance 'system-requirement
:name (string-downcase (string name))
:source (when source
(find-source-or-error (clpmfile-user-global-sources clpmfile)
(find-source-or-error (context-user-sources clpmfile)
source))
:version-spec version
:why t)
(clpmfile-user-requirements clpmfile))))
(context-requirements clpmfile))))
(defun read-clpmfile-from-stream (stream pathname)
(let ((clpmfile (make-instance 'clpmfile :pathname pathname))
(let ((clpmfile (make-instance 'context :name pathname))
(source-allowed-p t))
(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 clpmfile API version")))
(with-forms-from-stream (stream form)
(destructuring-bind (type . args) form
(when (and (eql type :source)
......@@ -255,34 +184,15 @@ instance."
(error "Global sources must be specified immediately after the API declaration"))
(when (and source-allowed-p
(not (eql type :source)))
(nreversef (clpmfile-user-global-sources clpmfile))
(nreversef (context-user-sources clpmfile))
(setf source-allowed-p nil))
(parse-clpmfile-form clpmfile type args)))
(nreversef (clpmfile-user-asd-files clpmfile))
(nreversef (clpmfile-user-requirements clpmfile))
clpmfile)))
(parse-clpmfile-form clpmfile type args))))
(nreversef (context-requirements clpmfile))
clpmfile))
(defun read-clpmfile (pathname)
"Read a ~clpmfile~ instance from ~pathname~."
"Read a clpmfile located at pathname. Returns a context object with only
sources and requirements populated."
(let* ((*default-pathname-defaults* (uiop:pathname-directory-pathname pathname)))
(with-open-file (stream pathname)
(read-clpmfile-from-stream stream pathname))))
(defmethod print-object ((obj clpmfile) stream)
(print-unreadable-object (obj stream :type t)
(terpri stream)
(prin1 :user-global-sources stream)
(write-char #\Space stream)
(write (clpmfile-user-global-sources obj) :stream stream)
(write-char #\Space stream)
(terpri stream)
(prin1 :user-asd-files stream)
(write-char #\Space stream)
(write (clpmfile-user-asd-files obj) :stream stream)
(write-char #\Space stream)
(terpri stream)
(prin1 :user-requirements stream)
(write-char #\Space stream)
(write (clpmfile-user-requirements obj) :stream stream)))
......@@ -17,9 +17,12 @@
#:clpm/source)
(:export #:context
#:context-add-requirement!
#:context-anonymous-p
#:context-asd-pathnames
#:context-find-system-asd-pathname
#:context-fs-source
#:context-installed-systems
#:context-name
#:context-output-translations
#:context-releases
#:context-requirements
......@@ -28,6 +31,8 @@
#:context-system-releases
#:context-to-asdf-source-registry-form
#:context-to-asdf-source-registry.d-forms
#:context-user-sources
#:context-vcs-source
#:context-visible-primary-system-names
#:context-write-asdf-files
#:copy-context
......@@ -52,10 +57,18 @@ pathname (if this is an anonymous context).")
:initform nil
:initarg :requirements
:accessor context-requirements)
(sources
(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
:initform nil
:initarg :sources
:accessor context-sources)
:initarg :user-sources
:accessor context-user-sources)
(releases
:initform nil
:initarg :releases
......@@ -73,6 +86,13 @@ pathname (if this is an anonymous context).")
in the context, the requirements that gave rise to those releases, etc. Contexts
can be named, global contexts, or anonymous."))
(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)))
(defun context-anonymous-p (context)
(pathnamep (context-name context)))
......@@ -82,7 +102,7 @@ can be named, global contexts, or anonymous."))
:releases (copy-list (context-releases context))
:requirements (copy-list (context-requirements context))
:reverse-dependencies (copy-alist (context-reverse-dependencies context))
:sources (copy-list (context-sources context))
:user-sources (copy-list (context-user-sources context))
:system-releases (copy-list (context-system-releases context))))
(defun global-context-pathname (name)
......@@ -99,6 +119,11 @@ can be named, global contexts, or anonymous."))
(t
(error "Unable to translate ~S to a context object" context-designator))))
(defun context-sources (context)
(list* (context-fs-source context)
(context-vcs-source context)
(context-user-sources context)))
;; * Adding requirements
......@@ -257,7 +282,7 @@ in place with the same name. Return the new requirement if it was modified."
(defun load-anonymous-context-from-pathname (pn)
(with-open-file (s pn)
(load-context-from-stream s)))
(load-context-from-stream s pn)))
(defun context-downselect-sources (name sources)
(let ((allowed-source-names (config-value :contexts name :sources)))
......@@ -273,12 +298,11 @@ in place with the same name. Return the new requirement if it was modified."
(with-open-file (s pn
:if-does-not-exist (if error :error nil))
(if s
(aprog1 (load-context-from-stream s)
(setf (context-name it) name)
(setf (context-sources it) (context-downselect-sources name (sources))))
(aprog1 (load-context-from-stream s name)
(setf (context-user-sources it) (context-downselect-sources name (sources))))
(make-instance 'context
:name name
:sources (context-downselect-sources name (sources)))))))
:user-sources (context-downselect-sources name (sources)))))))
(defgeneric check-section-valid (prev-section current-section)
(:method (prev-section current-section)
......@@ -349,15 +373,16 @@ in place with the same name. Return the new requirement if it was modified."
(unless (or (source-can-lazy-sync-p source)
(config-value :local))
(sync-source source))
(setf (context-sources context) (append (context-sources context) (list source)))))
(setf (context-user-sources context) (append (context-user-sources context) (list source)))))
(defun load-context-from-stream (stream)
(defun load-context-from-stream (stream name)
(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")))
(let ((out (make-instance 'context)))
(let ((out (make-instance 'context
:name name)))
;; The next forms are either tags or lists. The tags denote sections.
(loop
:with section := nil
......
......@@ -33,12 +33,6 @@
((name
:initarg :name
:accessor source-name)
(root-pathname
:initarg :root-pathname
:initform #p""
:accessor fs-source-root-pathname
:documentation "The root directory of this source. If relative, it is
resolved with respect to *DEFAULT-PATHNAME-DEFAULTS*.")
(project
:accessor fs-source-project
:documentation "The single project in this source.")
......@@ -63,8 +57,8 @@ system files, system files must be registered with the source using
FS-SOURCE-REGISTER-ASD."))
(defmethod make-source ((type (eql 'fs-source)) &rest initargs
&key system-files name root-pathname)
(with-clpm-session (:key `(make-source ,type ,name ,root-pathname))
&key system-files name)
(with-clpm-session (:key `(make-source ,type ,name))
(aprog1 (apply #'make-instance
type
initargs)
......@@ -78,7 +72,6 @@ FS-SOURCE-REGISTER-ASD."))
&allow-other-keys)
"Construct the singleton project and release."
(declare (ignore initargs))
(assert (uiop:directory-pathname-p (fs-source-root-pathname source)))
(let* ((project (make-instance 'fs-project
:name :all
:source source))
......@@ -135,8 +128,6 @@ file with the same primary name and construct a new system for it."
(defun fs-source-register-asd (fs-source asd-pathname)
"Given a pathname to an asd file, register it with the source. asd-pathname
can be relative (to the source's root dir) or absolute."
(unless (uiop:relative-pathname-p asd-pathname)
(setf asd-pathname (enough-namestring asd-pathname (merge-pathnames (fs-source-root-pathname fs-source)))))
(let* ((primary-name-ht (fs-source-system-files-by-primary-name fs-source))
(namestring-ht (fs-source-system-files-by-namestring fs-source))
(namestring (namestring asd-pathname)))
......@@ -154,19 +145,12 @@ can be relative (to the source's root dir) or absolute."
(system-files (release-system-files release)))
`(,(source-name source)
:type :file-system
,@(unless (uiop:pathname-equal (fs-source-root-pathname source)
(uiop:make-pathname* :directory '(:relative)))
`(:root-pathname ,(namestring (fs-source-root-pathname source))))
:system-files ,(mapcar #'system-file-asd-enough-namestring system-files))))
:system-files ,(mapcar #'system-file-asd-enough-namestring system-files))))
(defun fs-source-from-form (form)
(destructuring-bind (type &key root-pathname system-files) form
(destructuring-bind (type &key system-files) form
(assert (eql type :file-system))
(aprog1 (make-instance 'fs-source
:root-pathname (if root-pathname
(pathname root-pathname)
(uiop:pathname-directory-pathname
(uiop:make-pathname* :directory '(:relative)))))
(aprog1 (make-instance 'fs-source)
(dolist (system-file system-files)
(fs-source-register-asd it system-file)))))
......@@ -272,8 +256,7 @@ release."
(defmethod system-file-absolute-asd-pathname ((system-file fs-system-file))
"Merge the enough pathname with the source's root dir."
(merge-pathnames (system-file-asd-enough-namestring system-file)
(merge-pathnames (fs-source-root-pathname (system-file-source system-file)))))
(merge-pathnames (system-file-asd-enough-namestring system-file)))
(defmethod system-file-system-releases ((system-file fs-system-file))
"Grovel over the system file if necessary to determine every system 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