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