(zilch semver): add semver library

This is necessary for Cargo resolving.

core/src/semver.sld

@@ -0,0 +1,148 @@
+(define-library (zilch semver)
+  (import
+    (scheme base)
+    (chicken base) (chicken format)
+    (srfi 152))
+  (export
+    version-major version-minor version-patch version-prerelease version-build-metadata
+    version-str parse-version
+    version=? version<?)
+
+  (begin
+    (define-record-type <version>
+      (make-version major minor patch prerelease build-metadata)
+      version?
+      (major version-major)
+      (minor version-minor)
+      (patch version-patch)
+      (prerelease version-prerelease)
+      (build-metadata version-build-metadata))
+   
+    (define (version-str vers)
+      (define out (string-append
+                    (number->string (version-major vers))
+                    "."
+                    (number->string (version-minor vers))
+                    "."
+                    (number->string (version-patch vers))))
+      (when (version-prerelease vers)
+        (set! out (string-append out "-" (string-join (version-prerelease vers) "." 'strict-infix))))
+      (when (version-build-metadata vers)
+        (set! out (string-append out "+" (string-join (version-build-metadata vers) "." 'strict-infix))))
+      out)
+
+    (define-record-printer (<version> version out)
+      (fprintf out "#<version ~A>" (version-str version)))
+
+    (define (parse-version version-string)
+      (define version-string-length (string-length version-string))
+      (define (is-terminator ch)
+        (member ch '(#\. #\+ #\-)))
+      (define (parse-until-next-splat index)
+       (define out-list '())
+       (define (tick)
+         (if (>= index version-string-length)
+           (values out-list #f #f)
+           (let*
+             ((next-terminator-index (string-index version-string is-terminator index))
+              (terminator (and next-terminator-index (string-ref version-string next-terminator-index))))
+             (cond
+              ((and terminator (char=? terminator #\.)) (set! out-list (append out-list (list (string-copy version-string index next-terminator-index)))) (set! index (+ next-terminator-index 1)) (tick))
+              ((not terminator) (set! out-list (append out-list (list (string-copy version-string index)))) (values out-list #f #f))
+              (else (set! out-list (append out-list (list (string-copy version-string index next-terminator-index)))) (values out-list next-terminator-index terminator))))))
+       (tick))
+
+      (define-values (version-parts next-index version-terminator) (parse-until-next-splat 0))
+      (unless (= (length version-parts) 3) (error "Version string has incorrect amount of version core parts" version-string))
+      (for-each (lambda (p) (when (string=? p "") (error "Version string contains empty part" version-string))) version-parts)
+
+      (define prerelease-parts #f)
+      (when (and next-index (char=? version-terminator #\-))
+        (let-values (((parts-tmp next-index-tmp terminator-tmp) (parse-until-next-splat (+ next-index 1))))
+          (set! prerelease-parts parts-tmp)
+          (set! next-index next-index-tmp)
+          (set! version-terminator terminator-tmp)
+          (for-each (lambda (p) (when (string=? p "") (error "Version string contains empty prerelease part" version-string))) prerelease-parts))
+        (when (eq? prerelease-parts '()) (error "Version string has prerelease indicator, but no prerelease identifiers." version-string)))
+
+      (define build-parts #f)
+      (when (and next-index (char=? version-terminator #\+))
+        (let-values (((parts-tmp next-index-tmp terminator-tmp) (parse-until-next-splat (+ next-index 1))))
+          (set! build-parts parts-tmp)
+          (set! next-index next-index-tmp)
+          (set! version-terminator terminator-tmp)
+          (for-each (lambda (p) (when (string=? p "") (error "Version string contains empty build part" version-string))) build-parts))
+        (when (eq? build-parts '()) (error "Version string has build indicator, but no build identifiers." version-string)))
+
+      (when next-index
+        (error "Version string has unknown part" version-string))
+
+      (make-version (string->number (list-ref version-parts 0)) (string->number (list-ref version-parts 1)) (string->number (list-ref version-parts 2)) prerelease-parts build-parts))
+
+    (define (version=? left right)
+      (when (not (version? left))
+        (set! left (parse-version left)))
+      (when (not (version? right))
+        (set! right (parse-version right)))
+      (and
+        (= (version-major left) (version-major right))
+        (= (version-minor left) (version-minor right))
+        (= (version-patch left) (version-patch right))
+        (equal? (version-prerelease left) (version-prerelease right))))
+    (define (is-digit-only str) (not (string-skip str (lambda (f) (member f '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))))))
+    (define (string-lexicographical<? left right)
+      (define left-len (string-length left))
+      (define right-len (string-length right))
+      (define (inner index)
+        (cond
+          ((and (>= index left-len) (>= index right-len)) #f)
+          ((>= index left-len) #f)
+          ((>= index right-len) #t)
+          (else
+            (let ((left-char (string-ref left index)) (right-char (string-ref right index)))
+              (cond
+                ((char<? left-char right-char) #t)
+                ((char>? left-char right-char) #f)
+                (else (inner (+ index 1))))))))
+      (inner 0))
+    (define (compare-prerelease left right)
+      (cond
+        ; Check for different lengths of prerelease lists.
+        ((and (eq? left '()) (not (eq? right '()))) #t)
+        ((and (not (eq? left '())) (eq? right '())) #f)
+        (else
+          (let*
+            ((left-is-number (is-digit-only (car left)))
+             (right-is-number (is-digit-only (car right)))
+             (left-number (and left-is-number (string->number (car left))))
+             (right-number (and right-is-number (string->number (car right)))))
+            (cond
+              ((and left-is-number right-is-number (< left-number right-number)) #t)
+              ((and left-is-number right-is-number (> left-number right-number)) #f)
+              ((and left-is-number right-is-number (= left-number right-number)) (compare-prerelease (cdr left) (cdr right)))
+              ((and left-is-number (not right-is-number)) #t)
+              ((and (not left-is-number) right-is-number) #f)
+              ; Neither left nor right are numbers.
+              ((string-lexicographical<? (car left) (car right)) #t)
+              ((string=? (car left) (car right)) (compare-prerelease (cdr left) (cdr right)))
+              (else #f))))))
+    (define (version<? left right)
+      (when (not (version? left))
+        (set! left (parse-version left)))
+      (when (not (version? right))
+        (set! right (parse-version right)))
+      ; Match out all non-matching major/minor versions
+      (cond
+        ((> (version-major left) (version-major right)) #f)
+        ((< (version-major left) (version-major right)) #t)
+        ((> (version-minor left) (version-minor right)) #f)
+        ((< (version-minor left) (version-minor right)) #t)
+        ((> (version-patch left) (version-patch right)) #f)
+        ((< (version-patch left) (version-patch right)) #t)
+        ; At this point, major/minor/patch are all identical.
+        ((and (version-prerelease left) (not (version-prerelease right))) #t)
+        ((and (not (version-prerelease left)) (version-prerelease right)) #f)
+        
+        ; Both ends have a prerelease version.
+        ((equal? (version-prerelease left) (version-prerelease right)) #f)
+        (else (compare-prerelease (version-prerelease left) (version-prerelease right)))))))

core/zilch.egg

@@ -37,5 +37,7 @@
   (extension zilch.statusbar
     (source "src/statusbar.sld")
     (component-dependencies zilch.magic zilch.nix.daemon))
+  (extension zilch.semver
+    (source "src/semver.sld"))
   (extension zilch.lib.getopt
     (source "src/lib/getopt.sld"))))