;;;; 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
  version-copy
  version? check-version error-version
  version-depth
  version-elements
  version-separators
  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)
  (chicken format)
  (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))

;;record-variants

(define-syntax define-record-type-variant
  (er-macro-transformer
   (lambda (form r c)
     (define (any p L)
       (and (pair? L)
            (or (p (car L))
                (any p (cdr L)))))
     (##sys#check-syntax 'define-record-type-variant form
                         '(_ _ #(variable 0)
                             #(variable 1) _ . _))
     (let* ((name-spec (cadr form))
            (name (if (pair? name-spec) (car name-spec) name-spec))
            (t (if (pair? name-spec) (cadr name-spec) name-spec))
            (variant? (lambda (type) (any (lambda (x) (c x (r type)))
                                          (caddr form))))
            (unsafe? (variant? 'unsafe))
            (unchecked? (variant? 'unchecked))
            (inline? (variant? 'inline))
            (constructor? (eq? name t))

            (conser (cadddr form))
            (predspec (car (cddddr form)))
            (pred (if (pair? predspec) (car predspec) predspec))
            (checker (if (and (pair? predspec)
                              (pair? (cdr predspec)))
                         (cadr predspec) #f))
            (slots (cdr (cddddr form)))
            (%begin (r 'begin))
            (%lambda (r 'lambda))
            (%define (if inline? (r 'define-inline) (r 'define)))
            (vars (cdr conser))
            (x (r 'x))
            (y (r 'y))
            (%getter-with-setter (r 'getter-with-setter))
            (slotnames (map car slots)))
       `(,%begin
         ,(if constructor?
              `(,%define ,conser
                         (##sys#make-structure
                          ,t
                          ,@(map (lambda (sname)
                                   (if (memq sname vars)
                                       sname
                                       '(##core#undefined)))
                                 slotnames)))
              `(,%begin))
         (,%define (,pred ,x) (##sys#structure? ,x ,t))
         ,(if checker
              `(,%define (,checker ,x)
                         (##core#check (##sys#check-structure ,x ,t)))
              `(,%begin))
         ,@(let loop ([slots slots] [i 1])
             (if (null? slots)
                 '()
                 (let* ([slot (car slots)]
                        (setters (memq #:record-setters ##sys#features))
                        (setr? (pair? (cddr slot)))
                        (getr `(,%lambda (,x)
                                         ,(if unchecked?
                                              `(,%begin)
                                              `(##core#check
                                                (##sys#check-structure ,x ,t)))
                                         ,(if unsafe?
                                              `(##sys#slot ,x ,i)
                                              `(##sys#block-ref ,x ,i)))))
                   `(,@(if setr?
                           `((,%define (,(caddr slot) ,x ,y)
                                       ,(if unchecked?
                                            `(,%begin)
                                            `(##core#check
                                              (##sys#check-structure ,x ,t)))
                                       ,(if unsafe?
                                            `(##sys#setslot ,x ,i ,y)
                                            `(##sys#block-set! ,x ,i ,y))))
                           '())
                     (,%define ,(cadr slot)
                               ,(if (and setr? setters)
                                    `(,%getter-with-setter ,getr ,(caddr slot))
                                    getr) )
                     ,@(loop (cdr slots) (add1 i)))))))))))

;;

;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       (struct semantic-version))

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

(: make-version         (integer ver-part #!optional ver-punc --> ver))
(: 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-elements     (ver --> ver-parts))
(: version-separators   (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 semantic-version 'semantic-version)
(define-record-type-variant semantic-version (unsafe unchecked inline)
  (make-ver cs ps)
  ver?
  (cs ver-parts ver-parts-set!)
  (ps ver-puncs ver-puncs-set!))

(define (vertyp? x) (and (ver? 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? l) (every ver-part? l))
(define (ver-puncs? l) (every ver-punc? l))

(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 cnt part #!optional (punc (default-punctuation)))
  (check-parts 'make-version (list part))
  (check-puncs 'make-version (list punc))
  (make-ver (make-list cnt part) (make-list (min 0 (sub1 cnt)) punc)) )

(define (version . parts)
  (if (null? (check-parts '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
    (vertyp? 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 (vertyp? 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-elements ver)
  (list-copy (ver-parts (check-version 'version-elements ver))) )

(define (version-separators ver)
  (list-copy (ver-puncs (check-version 'version-separators 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) )

;; Read/Print Syntax

(define (version-print ver out)
  (fprintf out "#<version ~S>" (version->string ver)) )

;;;

(set! (record-printer semantic-version) version-print)

) ;module semantic-version