M qlfile => qlfile +2 -0
@@ 2,4 2,6 @@ ql trivial-package-local-nicknames
ql trivial-features
ql trivial-indent
ql alexandria
+ql cl-semver
git cl-i git@git.sr.ht:~skin/cl-i :branch main
+git nrdl git@git.sr.ht:~skin/nrdl :ref 0.3.0
M qlfile.lock => qlfile.lock +8 -0
@@ 18,7 18,15 @@
(:class qlot/source/ql:source-ql
:initargs (:%version :latest)
:version "ql-2023-10-21"))
+("cl-semver" .
+ (:class qlot/source/ql:source-ql
+ :initargs (:%version :latest)
+ :version "ql-2023-10-21"))
("cl-i" .
(:class qlot/source/git:source-git
:initargs (:remote-url "git@git.sr.ht:~skin/cl-i" :branch "main")
:version "git-2c5681b4db0a84e707ee20b8a0feb83424783b9e"))
+("nrdl" .
+ (:class qlot/source/git:source-git
+ :initargs (:remote-url "git@git.sr.ht:~skin/nrdl" :ref "0.3.0")
+ :version "git-0.3.0"))
M src/resolve.lisp => src/resolve.lisp +269 -28
@@ 1,8 1,17 @@
+#+(or)
+(declaim (optimize (speed 0) (space 0) (debug 3)))
(defpackage #:skin.djha.zippm/resolve
(:use :cl)
(:import-from #:uiop)
(:import-from #:alexandria)
- )
+ (:import-from #:cl-semver)
+ (:import-from #:esrap
+ #:defrule
+ #:character-ranges
+ #:parse
+ #:?)
+ (:export #:make-package-info
+ ))
(in-package #:skin.djha.zippm/resolve)
@@ 14,24 23,87 @@
(:not-equal . "!=")
(:less-equal . "<=")
(:less-than . "<")
- (:matches . "<>")
- (:in-range . "=>")
(:pess-greater . "><"))))
+(deftype version-relation ()
+ '(member
+ :greater-than
+ :greater-equal
+ :equal-to
+ :not-equal
+ :less-equal
+ :less-than
+ :pess-greater)
+ )
+
(defclass version-predicate ()
- ((relation :initarg :relation :reader relation)
- (version :initarg :version :reader version))
+ ((relation
+ :type version-relation
+ :initarg :relation :reader relation)
+ (version
+ :type cl-semver:semantic-version
+ :initarg :version :reader version))
(:documentation "A class to represent a version predicate."))
(defmethod print-object ((obj version-predicate) strm)
- (format strm "~A~A"
- (gethash (relation obj) relation-strings)
- (version obj)))
+ (format strm "~A"
+ (gethash (relation obj) relation-strings))
+ (cl-semver:print-version (version obj) strm))
+
+(deftype requirement-status ()
+ '(member :present :absent)
+ )
+
+(defclass package-info ()
+ ((name :initarg :name
+ :initform (error "A package name is required.")
+ :type string
+ :reader name)
+ (version :initarg :version
+ :type cl-semver:semantic-version
+ :initform (error "A package version is required.")
+ :reader version)
+ (location :initarg :location
+ :type string
+ :initform (error "A package location is required.")
+ :reader location)
+ (requirements :initarg :requirements
+ :initform nil
+ :type list ;; of lists of version requirements
+ :reader requirements))
+ (:documentation "A class to represent package information."))
+
+(defmethod print-object ((obj package-info) strm)
+ (format strm "~A:"
+ (name obj))
+ (cl-semver:print-version (version obj) strm)
+ (format strm "@~A(~{~{~A~^|~}~^&~})"
+ (location obj)
+ (requirements obj)))
+
+(deftype requirer ()
+ '(or (member :root) package-info))
+
+(defparameter *requirer* :root
+ "
+ The requirer that will be used as the default requirer for requirements.
+ This field is mostly important when building the dependency graph, at the end.
+ ")
(defclass requirement ()
- ((status :initarg :status :reader status)
- (name :initarg :name :reader name)
- (spec :initarg :spec :reader spec))
+ ((status :initarg :status
+ :type requirement-status
+ :reader status)
+ (name :initarg :name
+ :type string
+ :reader name)
+ (spec :initarg :spec
+ :type list
+ :reader spec)
+ (requirer :initarg :requirer
+ :type requirer
+ :initform *requirer*
+ :reader requirer))
(:documentation "A package requirement."))
(defmethod print-object ((obj requirement) strm)
@@ 40,12 112,189 @@
(name obj)
(spec obj)))
-(defclass package-info
- ((name :initarg :name :reader name)
- (version :initarg :version :reader version)
- (location :initarg :location :reader location)
- (requirements :initarg :requirements :reader requirements))
- (:documentation "A class to represent package information."))
+(defun decorate (requirement requirer)
+ (make-instance 'requirement
+ :status (status requirement)
+ :name (name requirement)
+ :spec (spec requirement)
+ :requirer requirer))
+
+;; TODO test
+(defun make-package-info (name version location requirements)
+ (let* ((base-instance (make-instance 'package-info
+ :name name
+ :version version
+ :location location))
+ (*requirer* base-instance)
+ (decorated-requirements
+ (mapcar
+ (lambda (conjunction)
+ (mapcar
+ (lambda (disjunction)
+ (decorate disjunction base-instance))
+ conjunction))
+ requirements)))
+
+ (setf (slot-value base-instance 'requirements) decorated-requirements)
+ base-instance))
+
+
+(defrule pess-greater "><"
+ (:constant :pess-greater))
+
+(defrule greater-equal ">="
+ (:constant :greater-equal))
+
+(defrule greater-than ">"
+ (:constant :greater-than))
+
+(defrule matches "<>"
+ (:constant :matches))
+
+(defrule less-equal "<="
+ (:constant :less-equal))
+
+(defrule less-than "<"
+ (:constant :less-than))
+
+(defrule equal-to "=="
+ (:constant :equal-to))
+
+(defrule not-equal "!="
+ (:constant :not-equal))
+
+(defrule version-predicate
+ (and
+ (or
+ pess-greater
+ greater-equal
+ greater-than
+ matches
+ less-equal
+ less-than
+ in-range
+ not-equal
+ equal-to)
+ cl-semver:version)
+ (:destructure (relation version)
+ (make-instance 'version-predicate :relation relation :version version)))
+
+(defrule vp-conjunction
+ (and
+ version-predicate
+ (*
+ (and
+ #\,
+ version-predicate)))
+ (:destructure (vp others)
+ (cons vp
+ (loop for (_ vps) in others
+ collect vps))))
+
+(defrule vp-disjunction
+ (and
+ vp-conjunction
+ (*
+ (and
+ #\;
+ vp-conjunction)))
+ (:destructure (vpc others)
+ (cons vpc
+ (loop for (_ vpcs) in others
+ collect vpcs))))
+
+(defrule package-name
+ (+ (not (or #\: #\@ #\( #\) #\& #\| #\! #\, #\; #\> #\< #\=)))
+ (:lambda (name)
+ (coerce name 'string)))
+
+
+(defrule version-requirement
+ (and
+ (? #\!)
+ package-name
+ (? vp-disjunction))
+ (:destructure (flag name spec)
+ (make-instance
+ 'requirement
+ :status
+ (if flag :absent :present)
+ :name (coerce name 'string)
+ :spec spec)))
+
+(defrule vr-conjunction
+ (and
+ vr-disjunction
+ (*
+ (and
+ #\&
+ vr-disjunction)))
+ (:destructure (vrc others)
+ (cons vrc
+ (loop for (_ vrcs) in others
+ collect vrcs))))
+
+(defrule vr-disjunction
+ (and
+ version-requirement
+ (*
+ (and
+ #\|
+ version-requirement)))
+ (:destructure (vr others)
+ (cons vr
+ (loop for (_ vrs) in others
+ collect vrs))))
+
+(defrule package-info
+ (and
+ package-name
+ #\:
+ cl-semver:version
+ #\@
+ (+ (not #\())
+ #\(
+ (? vr-conjunction)
+ #\)
+ )
+ (:destructure (name colon version at location open-paren requirements close-paren)
+ (declare (ignore colon at open-paren close-paren))
+ (make-package-info name version (coerce location 'string) requirements)))
+
+
+
+
+#+(or)
+(progn
+ (parse 'version-predicate ">=1.2.3")
+ (parse 'vp-disjunction ">=1.2.3,<=2.0.0,=>1.5.0;><3.0.0,!=3.2.3")
+ (requirer (parse 'version-requirement "!foo>=1.2.3,<=2.0.0,=>1.5.0;><3.0.0,!=3.2.3"))
+ (parse 'version-requirement "foo>=1.2.3,<=2.0.0,=>1.5.0;><3.0.0,!=3.2.3")
+ )
+
+
+
+#+(or)
+
+
+;; => seven-bros:1.2.3@/tmp/foo(adam>=1.2.3,<=1.9.7,!=1.5.0;><3.0.0|benjamin==89.1.0;==89.5.0;==94.1.0&!caleb|caleb>=5.0.0-alpha.3,<5.0.0&daniel)
+
+;; This was for an older version that used parse, but we're going to use parse
+;; elsewhere instead.
+#+(or)
+(make-instance 'package-info
+ :name "foo"
+ :version (cl-semver:read-version-from-string "1.2.3")
+ :location "/tmp/foo"
+ :requirements
+ (list
+ (list
+ (parse 'version-requirement "bar>=1.2.3,<=2.0.0,=>1.5.0;><3.0.0,!=3.2.3")
+ (parse 'version-requirement "il>=1.2.3,<=2.0.0,=>1.5.0;><3.0.0,!=3.2.3"))
+ (list
+ (parse 'version-requirement "for>=1.2.3,<=2.0.0,=>1.5.0;><3.0.0,!=3.2.3")
+ (parse 'version-requirement "baz>=1.2.3,<=2.0.0,=>1.5.0;><3.0.0,!=3.2.3"))))
+
(defun present (name &key spec)
(make-instance 'requirement :status :present :name name :spec spec))
@@ 53,16 302,8 @@
(defun absent (name &key spec)
(make-instance 'requirement :status :absent :name name :spec spec))
-(defun spec-holds (cmp spec package)
- (declare (type (or null version-predicate) spec)
- (type package-info package))
- (if (null spec)
- t
- (let ((pkg-version (version package)))
- (reduce (lambda (disj-acc disj-req)
- (or disj-acc
- (reduce
- (lambda (conj-acc conj-req)
- (make-comparison
+
+(defgeneric fulfills (requirement package)
+ (:documentation "A generic function to determine if a package fulfills a requirement."))
D src/version.lisp => src/version.lisp +0 -147
@@ 1,147 0,0 @@
-(defpackage #:skin.djha.zippm/version
- (:use :cl)
- (:import-from #:uiop)
- (:import-from #:alexandria)
- (:documentation
- "Version comparison for zippm"))
-
-(in-package #:skin.djha.zippm/version)
-
-(defparameter *trumpc* #\-)
-(defparameter *fillerc* #\Space)
-
-(defun nonnumeric-part-compare
- (a b)
- "
- Compare two version parts which both consist entirely of
- non-digits (or are empty).
- "
- (declare (type string a b))
- (loop with maxlength = (max (length a) (length b))
- for i from 0 below maxlength
- for ca = (if (< i (length a))
- (elt a i)
- *fillerc*)
- for cb = (if (< i (length b))
- (elt b i)
- *fillerc*)
- do
- (let ((diff
- (cond ((char= ca cb) 0)
- ((char= ca *trumpc*) -1)
- ((char= cb *trumpc*) 1)
- ((and (alpha-char-p a)
- (not (alpha-char-p b))) -1)
- ((and (alpha-char-p b)
- (not (alpha-char-p a))) 1)
- (:else
- (- (char-code a) (char-code b))))))
- (when (not (zerop diff))
- (return diff)))
- finally (return 0)))
-
-(defun numeric-part-compare
- (a b)
- "
- Compares two version parts, which both consist
- entirely of digits (or are empty).
- "
- (declare (type string a b))
- (let ((trimmed-a (string-left-trim '(#\0) a))
- (trimmed-b (string-left-trim '(#\0) b))
- (ldiff (- (length trimmed-a)
- (length trimmed-b))))
- (if (zerop ldiff)
- (cond ((string= trimmed-a trimmed-b) 0)
- ((string< trimmed-a trimmed-b) -1)
- :else 1)
- ldiff)))
-
-(defun version-part-compare (i a b)
- "
- Compare the `i`th part of the parts of version strings `a` and `b`, as found
- by `version-parts-split`.
- "
- (declare (type fixnum i)
- (type string a b))
- (let ((comparator (if (zerop (mod i 2))
- #'nonnumeric-part-compare
- #'numeric-part-compare)))
- (funcall comparator a b)))
-
-(defun version-parts-split
- (version)
- "
- Split a version string up into its component parts, with digits in the `0,2,4,...`th
- spots and non-digits in the `1,3,5,...`th spots.
- "
- (declare (type string version))
- (loop
- with parts = (make-array 10
- :element-type 'string
- :initial-element ""
- :adjustable t
- :fill-pointer 0)
- for i = 0 then (1+ i)
- for check = (if (zerop (mod i 2))
- #'digit-char-p
- (complement #'digit-char-p))
- for scratch = version then (subseq scratch next-checked)
- for next-checked = (or
- (position-if check scratch)
- (length scratch))
- while (not (zerop (length scratch)))
- do
- (vector-push-extend (subseq scratch 0 next-checked) parts)
- finally (return parts)))
-
-(defun epochless-vercmp (a b)
- "
- Compare two version numbers, assuming that neither has an epoch.
- "
- (declare (type string a b))
- (if (equal a b)
- 0
- (let ((split-a (version-parts-split a))
- (split-b (version-parts-split b)))
- (loop with maxlength = (max (length split-a) (length split-b))
- for i = 0 below maxlength
- for a = (if (< i (length split-a))
- (elt split-a i)
- "")
- for b = (if (< i (length split-b))
- (elt split-b i)
- "")
- for cmp = (version-part-compare i a b)
- while (zerop cmp)
- finally (return cmp))))))
-
-(defun epoch
- (a)
- "
- Extract the epoch from a debian version string.
- "
- (let ((found (position #\: a)))
- (if found
- (values (parse-integer (subseq a 0 found))
- (subseq a (1+ found)))
- (values 0 a))))
-
-(defun vercmp
- (a b)
- "
- Compares two version numbers according to the rules laid out in the [Debian
- Policy
- Manual](https://www.debian.org/doc/gpolicy/ch-controlfields.html#s-f-Version),
- retrieved 2024-02-15.
-
- Epoch numbers, upstream versions, and revision version parts are fully
- supported.
- "
- (multiple-value-bind (a-epoch a-vers) (epoch a)
- (multiple-value-bind (b-epoch b-vers) (epoch b)
- (if (= a-epoch b-epoch)
- (epochless-gvercmp a-vers b-vers)
- (- a-epoch b-epoch)))))
-
-;; TODO TEST
M tests/main.lisp => tests/main.lisp +103 -8
@@ 1,29 1,41 @@
(defpackage #:zippm/tests/resolve
(:use #:cl
- #:skin.djha.zippm/resolve
- #:rove))
+ #:rove)
+ (:import-from
+ #:skin.djha.zippm/resolve)
+ (:import-from
+ #:cl-semver)
+ (:import-from #:esrap)
+ (:local-nicknames
+ (#:resolve #:skin.djha.zippm/resolve)))
+
(in-package #:zippm/tests/resolve)
;; NOTE: To run this test file, execute `(asdf:test-system :zippm)' in your Lisp.
+(or)
(rove:run-test *)
+(cl-semver:enable-version-syntax)
+
+;; TODO: Get tests in for
+
+
(deftest basic-structures
(testing
"Make a version predicate"
(let ((p (make-instance 'skin.djha.zippm/resolve::version-predicate
:relation :greater-equal
- :version "1.0"))
+ :version #v"1.0"))
(q (make-instance 'skin.djha.zippm/resolve::version-predicate
:relation :less-than
- :version "2.0"))
+ :version #v"2.0"))
(s (make-instance 'skin.djha.zippm/resolve::version-predicate
:relation :equal-to
- :version "2.3")))
+ :version #v"2.3")))
(ok (string=
(format nil "~A" p)
- ">=1.0"))
+ ">=1.0.0"))
(let ((present-r (make-instance 'skin.djha.zippm/resolve::requirement
:status :present
:name "foo"
@@ 33,6 45,89 @@
(,s)))))
(ok (string=
(format nil "~A" present-r)
- "foo>=1.0,<2.0;==2.3")
+ "foo>=1.0.0,<2.0.0;==2.3.0")
+
+ "foo>=1.0.0,<2.0.0;==2.3.0"))))
+ (testing "Make a package information object"
+ ;; TODO: Make tests use the parse stuff
+ (let ((pio
+ (resolve:make-package-info "seven-bros" (cl-semver:read-version-from-string "1.2.3") "/tmp/foo"
+ (list
+ (list
+ (make-instance 'resolve::requirement
+ :status :present
+ :name "adam"
+ :spec
+ (list
+ (list
+ (make-instance 'resolve::version-predicate
+ :relation :greater-equal
+ :version (cl-semver:read-version-from-string "1.2.3"))
+ (make-instance 'resolve::version-predicate
+ :relation :less-equal
+ :version (cl-semver:read-version-from-string "1.9.7"))
+ (make-instance 'resolve::version-predicate
+ :relation :not-equal
+ :version (cl-semver:read-version-from-string "1.5.0"))
+ )
+ (list
+ (make-instance 'resolve::version-predicate
+ :relation :pess-greater
+ :version (cl-semver:read-version-from-string "3.0.0"))
+ )
+ )
+ )
+ (make-instance 'resolve::requirement
+ :status :present
+ :name "benjamin"
+ :spec
+ (list
+ (list
+ (make-instance 'resolve::version-predicate
+ :relation :equal-to
+ :version (cl-semver:read-version-from-string "89.1.0")))
+ (list
+ (make-instance 'resolve::version-predicate
+ :relation :equal-to
+ :version (cl-semver:read-version-from-string "89.5.0")))
+ (list
+ (make-instance 'resolve::version-predicate
+ :relation :equal-to
+ :version (cl-semver:read-version-from-string "94.1.0")))))
+ )
+ (list
+ (make-instance 'resolve::requirement
+ :status :absent
+ :name "caleb"
+ :spec nil)
+ (make-instance 'resolve::requirement
+ :status :present
+ :name "caleb"
+ :spec
+ (list
+ (list
+ (make-instance 'resolve::version-predicate
+ :relation :greater-equal
+ :version (cl-semver:read-version-from-string "5.0.0-alpha.3"))
+ (make-instance 'resolve::version-predicate
+ :relation :less-than
+ :version (cl-semver:read-version-from-string "5.0.0"))
+ )
+ )
+ ))
+ (list
+ (make-instance 'resolve::requirement
+ :status :present
+ :name "daniel"
+ :spec
+ nil
+ )))))
+ (pio-string "seven-bros:1.2.3@/tmp/foo(adam>=1.2.3,<=1.9.7,!=1.5.0;><3.0.0|benjamin==89.1.0;==89.5.0;==94.1.0&!caleb|caleb>=5.0.0-alpha.3,<5.0.0&daniel)"))
+ (ok (string= (format nil "~A" pio)
+ pio-string))
+ (ok (string= (format nil "~A" (esrap:parse 'resolve::package-info pio-string))
+ pio-string)))))
+
+
+
- "foo>=1.0,<2.0;==2.3")))))
D tests/version.lisp => tests/version.lisp +0 -37
@@ 1,37 0,0 @@
-(defpackage #:skin.djha.zippm/tests/version
- (:use #:cl
- #:rove)
- (:import-from #:skin.djha.zippm/version))
-(in-package #:skin.djha.zippm/tests/version)
-
-;; NOTE: To run this test file, execute `(asdf:test-system :zippm)' in your Lisp.
-+(or)
-(rove:run-test *)
-
-(deftest version-parts-split
- (testing
- "The empty case. This case doesn't really make sense, but it's here for
- completeness."
- (ok (equal (skin.djha.zippm/version::version-parts-split "") nil)))
- (testing
- "Some simple cases"
- (ok (equal (skin.djha.zippm/version::version-parts-split " ") '(" ")))
- (ok (equal (skin.djha.zippm/version::version-parts-split "5") '("" "5")))
- (ok (equal (skin.djha.zippm/version::version-parts-split "1.0")
- '("" "1" "." "0")))
- (ok (equal (skin.djha.zippm/version::version-parts-split "1.0.0")
- '("" "1" "." "0" "." "0"))))
- (testing
- "A case with a numeric suffix"
- (ok (equal (skin.djha.zippm/version::version-parts-split "5.3.alpha17")
- '("" "5" "." "3" ".alpha" "17"))))
- (testing
- "Concerning dots"
- (ok (equal (skin.djha.zippm/version::version-parts-split ".a1")
- '(".a" "1")))
- (ok (equal (skin.djha.zippm/version::version-parts-split "5.a1")
- '("" "5" ".a" "1"))))
- (testing
- "A case with a tilde"
- (ok (equal (skin.djha.zippm/version::version-parts-split "1.0~alpha")
- '("" "1" "." "0" "~alpha")))))