puck/zilch
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

(zilch semver): add semver library

Browse source 
This is necessary for Cargo resolving.
This commit is contained in:
puck 2024-11-21 17:08:50 +00:00
parent b59fd781d0
commit d52a1e7796
2 changed files with 150 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

148
core/src/semver.sld Normal file
View file

@ -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)))))))