;;;; semantic-version.components.scm  -*- Scheme -*-
;;;; Kon Lovett, Jun '22

;; Issues
;;
;; - Lot'sa overhead

(module semantic-version.components

(;export
  ;
  make-version-component
  version-component? check-version-component error-version-component
  ;
  version-component-lookup
  version-component-converts
  version-component-compare
  ;
  version-components-update!
  ;
  version-component-object
  version-component-string
  version-component-next
  version-component-prev
  ;
  version-component-literal)

(import scheme utf8
  (chicken base)
  (chicken type)
  (only (srfi 1) find-tail)
  (only vector-lib vector-copy vector-every))

;;Types

;NOTE symbols are not preserved; the printname is used!
(include-relative "semantic-version.types")

;;

(include-relative "semantic-version-internals")

;utf8 string extras, from (chicken string)

(define (string-compare3 s1 s2)
  (import (only (chicken base) constantly))
  (import (only utf8-srfi-13 string-compare))
  (check-string 'string-compare3 s1)
  (check-string 'string-compare3 s2)
  (let ((len1 (string-length s1))
        (len2 (string-length s2)) )
    (let* ((len (min len1 len2))
           (cmp (string-compare s1 s2 (constantly -1) (constantly 0) (constantly 1) 0 len 0 len)) )
      (if (zero? cmp) (- len1 len2)
          cmp) ) ) )

(define (symbol-compare3 x y) (string-compare3 (symbol->string x) (symbol->string y)))

;; Version Element Declarations

;(or number string symbol enum') (is-a? Enum enum')
(define-type version-part *)

;should be disjoint but defs order is little-endian
(define-type version-part? (* -> boolean : version-part))
(define-type version-part-compare (* * --> fixnum))

;probably will need to map strings to symbols again but I/O only
(define-type string->version-part (string --> (or false version-part)))
(define-type version-part->string (version-part --> string))

;maps to the next/previous idempotent value in the set or #f
(define-type version-part-next (* --> (or false version-part)))
(define-type version-part-prev (* --> (or false version-part)))

;version-component-literal
(define-type version-part->literal (version-part --> *))

(define-type version-component (vector
  version-part? version-part-compare
  string->version-part version-part->string
  version-part-next version-part-prev
  version-part->literal))
(define-type version-components (list-of version-component))

(: make-version-component (version-part? version-part-compare
                           string->version-part version-part->string
                           version-part-next version-part-prev
                           version-part->literal -> version-component))
(: version-component? (* -> boolean : version-component))
(: check-version-component (symbol * #!optional (or symbol string) -> version-component))
(: error-version-component (symbol * #!optional (or symbol string) -> void))

(: version-component-lookup (* -> (or false version-component)))
(: version-component-converts (string -> (or false version-component) *))

(: version-components-update! (version-component -> void))

(: version-component-compare (* * --> integer))

(: version-component-string (version-part -->  string))
(: version-component-object (string -->  version-part))
(: version-component-next (* #!optional fixnum --> (or false version-part)))
(: version-component-prev (* #!optional fixnum --> (or false version-part)))

(: version-component-literal (* -->  *))

;;

(define (make-version-component vp? vp-cmp str->vp vp->str vp-next vp-prev vp->lit)
  (check-version-component 'make-version-component
                           (vector vp? vp-cmp str->vp vp->str vp-next vp-prev vp->lit)) )

(define (vp-pred x) (vector-ref x 0))
(define (vp-cmp x) (vector-ref x 1))
(define (str->vp x) (vector-ref x 2))
(define (vp->str x) (vector-ref x 3))
(define (vp-next x) (vector-ref x 4))
(define (vp-prev x) (vector-ref x 5))
(define (vp->lit x) (vector-ref x 6))

(define (version-component? obj)
  (and (vector? obj)
       (= 7 (vector-length obj))
       (vector-every procedure? obj)))

(define (error-version-component loc obj #!optional nam)
  (error loc "not a version-component" obj) )

(define (check-version-component loc obj #!optional nam)
  (unless (version-component? obj) (error-version-component loc obj nam))
  obj )

;foldl style predicate, flows 1st successful string conversion thru,
;remembering the component
(define ((string-converts str) i ecomp)
  (or i
      (and-let* ((obj ((str->vp ecomp) str))
                 (pred (vp-pred ecomp))
                 (pred obj) )
        `(,obj . ,ecomp) ) ) )

(define (match-predicates ecomp)
  (let ((pred (vector-ref ecomp 0)))
    (lambda (x) (eq? pred (vp-pred x)))) )

;;

(define *version-components* '())

(define (version-component-location pred)
  (find-tail pred *version-components*) )

;deesn't exist, adds at end
;exists, updates in place
;doesn't share ncomp!
(define (version-components-update! ncomp)
  (let* ((ncomp (vector-copy (check-version-component 'version-components-update! ncomp)))
         (cell (version-component-location (match-predicates ncomp))) )
    (if (not cell)
        (set! *version-components* `(,@*version-components* ,ncomp))
        (set! (car cell) ncomp) ) ) )

(define (version-component-converts str)
  (let* ((res (foldl (string-converts str) #f *version-components*)))
    (values (and res (car res)) (and res (cdr res))) ) )

;;

(define (version-component-lookup obj)
  (and-let* ((pred (if (procedure? obj)
                       (lambda (x) (eq? (vp-pred x) obj))
                       (lambda (x) ((vp-pred x) obj))))
             (cell (version-component-location pred)) )
    (car cell) ) )

(define (version-component-compare a b)
  (let ((vp1 (version-component-lookup a))
        (vp2 (version-component-lookup b)) )
    (cond ((eq? vp1 vp2) ((vp-cmp vp1) a b))
          ;FIXME builtin precedence
          ((number? a) -1)
          ((number? b) 1)
          ;generic compare
          (else
            (string-compare3 ((vp->str vp1) a) ((vp->str vp2) b))) ) ) )

(define (version-component-string x)
  (and-let* ((vcomp (version-component-lookup x)))
    ((vp->str vcomp) x) ) )

(define (version-component-object x)
  (let-values (((obj vcomp) (version-component-converts x)))
     obj ) )

(define (version-component-literal x)
  (and-let* ((vcomp (version-component-lookup x)))
    ((vp->lit vcomp) x) ) )

(define (version-component-next x #!optional (amt 1))
  (and-let* ((vcomp (version-component-lookup x))
             (nxt (vp-next vcomp)) )
    (do ((i amt (sub1 i))
         (x x (nxt x)) )
        ((zero? i) x) ) ) )

(define (version-component-prev x #!optional (amt 1))
  (and-let* ((vcomp (version-component-lookup x))
             (prv (vp-prev vcomp)) )
    (do ((i amt (sub1 i))
         (x x (prv x)) )
        ((zero? i) x) ) ) )

;; Pre-defined (builtin) version-components

;number => + | - | identity
(define vp-integer (make-version-component integer?
                                           -
                                           string->number number->string
                                           add1 sub1
                                           identity))

;string => <error> | <error> | identity
(define vp-string (make-version-component string?
                                          string-compare3
                                          identity identity
                                          (constantly #f) (constantly #f)
                                          identity))

;symbol => <error> | <error> | symbol->string
(define vp-symbol (make-version-component symbol?
                                          symbol-compare3
                                          string->symbol symbol->string
                                          (constantly #f) (constantly #f)
                                          symbol->string))

(version-components-update! vp-integer)
(version-components-update! vp-string)
(version-components-update! vp-symbol)

;enum   => enum-next | enum-prev
;   SRFI 209 - is disjoint
; miscmacros - is NOT disjoint (from number), override symbol

) ;module semantic-version.components