diff --git a/core/src/semver.sld b/core/src/semver.sld new file mode 100644 index 0000000..3d4b2a3 --- /dev/null +++ b/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 + (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 out) + (fprintf out "#" (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= 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) #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 (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))))))) diff --git a/core/zilch.egg b/core/zilch.egg index 7398f54..3f7334d 100644 --- a/core/zilch.egg +++ b/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"))))