;;;; semantic-version.scm  -*- Scheme -*-
;;;; Kon Lovett, Apr '21

;; Issues
;;
;; - Support Roman Numerals & Upper/Lowercase Letters ("outline numbers").
;;
;; - Change representation to record w/ vector "arms".

(module semantic-version

(;export
  version-punctuation
  version-tail-zero
  make-version
  version-copy
  version? check-version error-version
  version-depth
  version-parts
  version-puncs
  list->version
  version->list
  version-compare
  version<? version=? version>? version<=? version>=?
  version-hash
  ;version*<? version*=? version*>? version*<=? version*>=?
  ;version*-hash
  version-comparator
  string->version
  version->string
  version-depth+!
  version-depth-!
  version-depth+
  version-depth-
  version-extend!
  version-extend
  version-inc! version-dec!
  version-inc version-dec)

(import scheme
  utf8
  (chicken base)
  (chicken type)
  (chicken condition)
  (only (chicken string) ->string string-compare3)
  (only (srfi 1) make-list list-copy drop-while reverse! append! drop-right! every map-in-order)
  (only utf8-srfi-13 string-filter string-index)
  (only (srfi 69) equal?-hash)
  (only (srfi 128) make-comparator))

;;

;NOTE symbols are not preserved; the printname is used!
(define-type ver-part  (or number string symbol))
(define-type ver-punc  char)
(define-type ver-parts (list-of ver-part))
(define-type ver-puncs (list-of ver-punc))
(define-type ver       (pair ver-parts ver-puncs))

(: version-punctuation  (#!optional string -> string))
(: version-tail-zero    (#!optional boolean -> boolean))

(: make-version         (#!rest ver-part --> ver))
(: version?             (* -> boolean : ver))
(: check-version        (symbol * #!optional (or string symbol) -> ver))
(: error-version        (symbol * #!optional (or string symbol) -> void))
(: version-copy         (ver --> ver))
(: version-depth        (ver --> integer))
(: version-parts        (ver --> ver-parts))
(: version-puncs        (ver --> ver-puncs))
(: list->version        ((list-of (or ver-part ver-punc)) --> ver))
(: version->list        (ver --> (list-of (or ver-part ver-punc))))
(: version-compare      (ver ver #!optional boolean --> integer))
(: version<?            (ver ver #!optional boolean --> boolean))
(: version=?            (ver ver #!optional boolean --> boolean))
(: version>?            (ver ver #!optional boolean --> boolean))
(: version<=?           (ver ver #!optional boolean --> boolean))
(: version>=?           (ver ver #!optional boolean --> boolean))
(: version-hash         (ver #!rest --> integer))
(: version-comparator   (--> (struct comparator)))
(: string->version      (string --> ver))
(: version->string      (ver --> string))
(: version-extend!      (ver #!rest (or ver-part ver-punc) -> ver))
(: version-extend       (ver #!rest (or ver-part ver-punc) --> ver))
(: version-depth+!      (ver integer ver-part #!optional ver-punc -> ver))
(: version-depth-!      (ver integer -> ver))
(: version-depth+       (ver integer ver-part #!optional ver-punc --> ver))
(: version-depth-       (ver integer --> ver))
(: version-inc!         (ver #!optional integer number -> ver))
(: version-dec!         (ver #!optional integer number -> ver))
(: version-inc          (ver #!optional integer number --> ver))
(: version-dec          (ver #!optional integer number --> ver))

;;

;semantic-version type

;NOTE symbols are not preserved; the printname is used!
(define (ver-part? x) (or (number? x) (string? x) (symbol? x)))
(define (ver-punc? x) (char? x))

(define (make-ver cs ps)      (cons cs ps))
(define (ver-parts v)         (car v))
(define (ver-puncs v)         (cdr v))
(define (ver-parts-set! v x)  (set-car! v x))
(define (ver-puncs-set! v x)  (set-cdr! v x))
(define (ver? x)              (and (pair? x) (list? (ver-parts x)) (list? (ver-puncs x))))
(define (copy-ver v)          (make-ver (list-copy (ver-parts v)) (list-copy (ver-puncs v))))

(define (ver-parts? x) (every ver-part? x))
(define (ver-puncs? x) (every ver-punc? x))

(define (vererrmsg msg nam)
  (string-append (or (and nam (->string nam)) "bad argument") " - " msg) )

(define (vererr loc obj msg nam)
  (error loc (vererrmsg msg nam) obj) )

(define (check-parts loc x #!optional nam)
  (unless (ver-parts? x) (vererr loc x "invalid semantic-version parts" nam))
  x )

(define (check-puncs loc x #!optional nam)
  (unless (ver-puncs? x) (vererr loc x "invalid semantic-version puncs" nam))
  x )

;

;"!?@#$%^&*-_+=|/\\;:,. "
;"#$%^&-_+=/\\;:,. "
;"._- +;:,"
(define-constant VERSION-PUNCT "._- +;:,")

(define version-punctuation (make-parameter VERSION-PUNCT))

(define version-tail-zero (make-parameter #f))

(define (drop-tailing-zeros ls)
  (reverse! (drop-while (lambda (x) (and (number? x) (zero? x))) (reverse ls))) )

(define (default-punctuation)
  (string-ref (version-punctuation) 0) )

(define (default-puncs parts)
  (make-list (sub1 (length parts)) (default-punctuation)) )

(define (make-version . parts)
  (if (null? (check-parts 'make-version parts)) (make-ver '() '())
    (let ((parts (map (lambda (x) (if (symbol? x) (symbol->string x) x)) parts)))
      (make-ver parts (default-puncs parts))) ) )

(define (version? ver)
  (and
    (ver? ver)
    (let ((parts (ver-parts ver)) (puncs (ver-puncs ver)))
      (or
        (and (null? puncs) (null? parts))
        (and
          (= (length puncs) (sub1 (length parts)))
          (ver-parts? parts)
          (ver-puncs? puncs) ) ) ) ) )

(define (error-version loc x #!optional nam)
  (vererr loc x "invalid semantic-version" nam) )

(define (check-version loc x #!optional nam)
  (unless (ver? x) (error-version loc x nam))
  (check-parts loc (ver-parts x) nam)
  (check-puncs loc (ver-puncs x) nam)
  x )

(define (version-copy ver)
  (copy-ver (check-version 'version-copy ver)) )

(define (version-depth ver)
  (length (ver-parts (check-version 'version-depth ver))) )

(define (version-parts ver)
  (list-copy (ver-parts (check-version 'version-parts ver))) )

(define (version-puncs ver)
  (list-copy (ver-puncs (check-version 'version-puncs ver))) )

(define (version->list ver)
  (check-version 'version->list ver)
  (let loop ((puncs (ver-puncs ver)) (parts (ver-parts ver)) (ls '()))
    (cond
      ((and (null? puncs) (null? parts))
        (reverse! ls) )
      ((= (length puncs) (length parts))
        (loop (cdr puncs) parts (cons (car puncs) ls)) )
      (else
        (loop puncs (cdr parts) (cons (car parts) ls)) ) ) ) )

(define (list->version ls)
  (define (str/num x) (if (number? x) x (->string x)))
  (let loop ((parts '()) (puncs '()) (ls ls))
    (cond
      ((null? ls)             (make-ver (reverse! parts) (reverse! puncs)))
      ((ver-part? (car ls))   (loop (cons (str/num (car ls)) parts) puncs (cdr ls)))
      ((ver-punc? (car ls))   (loop parts (cons (car ls) puncs) (cdr ls)))
      (else
        (error 'list->version "invalid version component" (car ls))) ) ) )

(define (version-compare ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
  (define (tail-zeros ls) (if tail-zero? ls (drop-tailing-zeros ls)))
  (let loop ((p1 (tail-zeros (ver-parts (check-version 'version-compare ver1))))
             (p2 (tail-zeros (ver-parts (check-version 'version-compare ver2)))))
    (cond
      ((and (null? p1) (null? p2))  0)
      ((null? p1)                   -1)
      ((null? p2)                   1)
      ((and (number? (car p1)) (number? (car p2)))
        (let ((cmp (- (car p1) (car p2))))
          (if (zero? cmp) (loop (cdr p1) (cdr p2))
            cmp ) ) )
      ((number? (car p1))           -1)
      ((number? (car p2))           1)
      ((string-compare3 (car p1) (car p2)) =>
        (lambda (cmp)
          (if (zero? cmp) (loop (cdr p1) (cdr p2))
            cmp ) ) ) ) ) )

(define (version<? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
  (negative? (version-compare ver1 ver2 tail-zero?)) )

(define (version=? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
  (zero? (version-compare ver1 ver2 tail-zero?)) )

(define (version>? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
  (positive? (version-compare ver1 ver2 tail-zero?)) )

(define (version<=? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
  (<= (version-compare ver1 ver2 tail-zero?) 0) )

(define (version>=? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
  (>= (version-compare ver1 ver2 tail-zero?) 0) )

(define (version-hash ver . rest)
  (define (tail-zeros ls) (if (version-tail-zero) ls (drop-tailing-zeros ls)))
  (apply equal?-hash (tail-zeros (ver-parts (check-version 'version-hash ver))) rest) )

#;
(define (version*=? ver1 ver2 #!optional (tail-zero? (version-tail-zero)))
  (and
    (zero? (version-compare ver1 ver2 tail-zero?))
    (equal? (ver-puncs1 ver) (ver-puncs ver2))) )

#;
(define (version*-hash ver . rest)
  (equal?-hash (check-version 'version-hash* ver) rest) )

(define (version-comparator)
  (make-comparator version? version=? version<? version-hash) )

;string-utils like
;"..." => string-parts char-puncs
;"a.3,c" => ("a" "3" "c") (#\. #\,)
(define (*string-unzip str punc-str)
  (let (
    (parts (string-split str punc-str #t))
    (punct (string->list (string-filter (cut string-index punc-str <>) str))) )
    (values parts punct) ) )

(define (string->version str)
  (define (str/num x) (or (string->number x) x))
  (let-values (((parts puncs) (*string-unzip str (version-punctuation))))
    (make-ver (map-in-order str/num parts) puncs) ) )

(define (version->string ver)
  (apply string-append (map-in-order ->string (version->list (check-version 'version->string ver)))) )

(define (version-depth+! ver cnt part #!optional (punc (default-punctuation)))
  (check-version 'version-depth+! ver)
  (check-parts 'version-depth+! (list part))
  (check-puncs 'version-depth+! (list punc))
  (ver-parts-set! ver (append! (ver-parts ver) (make-list cnt part)))
  ;need to include leading punct!
  (ver-puncs-set! ver (append! (ver-puncs ver) (make-list cnt punc)))
  ver )

(define (version-depth-! ver cnt)
  (check-version 'version-depth-! ver)
  (cond
    ((zero? cnt)
      ver )
    ((positive? cnt)
      (let ((puncs (ver-puncs ver)) (parts (ver-parts ver)))
        (unless (<= cnt (length parts))
          (error 'version-depth-! "semantic-version cannot drop such depth" ver cnt) )
        ;be direct when dropping all
        (ver-parts-set! ver (if (= cnt (length parts)) '() (drop-right! parts cnt)))
        ;need to drop leading punctuation
        (ver-puncs-set! ver (if (= cnt (length parts)) '() (drop-right! puncs cnt)))
        ver ) )
    (else
      (error 'version-depth-! "semantic-version cannot drop negative depth" ver cnt)) ) )

(define (version-depth+ ver cnt part #!optional (punc (default-punctuation)))
  (version-depth+! (copy-ver (check-version 'version-depth+ ver)) cnt part punc) )

(define (version-depth- ver cnt)
  (version-depth-! (copy-ver (check-version 'version-depth- ver)) cnt) )

(define (version-extend ver . comps)
  (list->version (append! (version->list (check-version 'version-extend ver)) comps)) )

(define (version-extend! ver . comps)
  (let ((vern (apply version-extend (check-version 'version-extend! ver) comps)))
    (ver-parts-set! ver (ver-parts vern))
    (ver-puncs-set! ver (ver-puncs vern)) )
  ver )

;default is the last component, better be a number!
(define (version-inc! ver #!optional idx (amt 1))
  (check-version 'version-inc! ver)
  (let loop ((idx (or idx (sub1 (length (ver-parts ver))))) (ls (ver-parts ver)))
    (if (positive? idx) (loop (sub1 idx) (cdr ls))
      (begin
        (set-car! ls (+ (car ls) amt))
        ver ) ) ) )

(define (version-dec! ver #!optional idx (amt 1))
  (version-inc! (check-version 'version-dec! ver) idx (- amt)) )

(define (version-inc ver #!optional idx (amt 1))
  (version-inc! (copy-ver (check-version 'version-inc ver)) idx amt) )

(define (version-dec ver #!optional idx (amt 1))
  (version-dec! (copy-ver (check-version 'version-dec ver)) idx amt) )

) ;semantic-version