;;;; 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)
  (chicken fixnum)
  (only utf8-srfi-13 string-compare)
  (only (srfi 1) find-tail)
  (only vector-lib vector-copy vector-every)
  (only record-variants define-record-type-variant))

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

;(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 version-component #!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 (* ->  *))

;;

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

(define-inline (check-positive-fixnum loc obj)
  (check-fixnum-range loc obj 0 most-positive-fixnum) )

;utf8 string extras, from (chicken string)

(define ^-1 (constantly -1))
(define ^0  (constantly 0))
(define ^+1 (constantly 1))
(define ^#f (constantly #f))

(define (string-compare3 s1 s2) (string-compare s1 s2 ^-1 ^0 ^+1))
(define (symbol-compare3 x y)   (string-compare3 (symbol->string x) (symbol->string y)))

;;

(define-constant COMPONENT-COUNT 7)

(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)
       (fx= COMPONENT-COUNT (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)) )
        (cons obj ecomp) ) ) )

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

;;

(define version-component-location)
(define version-components-update!)
(define version-component-converts)
(let ((+version-components+ '()))

  (set! version-component-location
    (lambda (pred)
      (find-tail pred +version-components+) ) )

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

  (set! version-component-converts
    (lambda (str)
      (let ((res (foldl (string-converts str) #f +version-components+)))
        (if res (values (car res) (cdr res))
            (values #f #f)) ) ) ) )

;;

(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))
          ((and (number? a) (number? b))  (- b a))
          ;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 comp)
  (and-let* ((vcomp (version-component-lookup comp)))
    ((vp->str vcomp) comp) ) )

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

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

(define (version-component-next comp #!optional (amt 1))
  (and-let* ((vcomp (version-component-lookup comp))
             (nxt (vp-next vcomp)) )
    (do ((amt (check-positive-fixnum 'version-component-next amt) (fx- amt 1))
         (icomp comp (nxt icomp)) )
        ((or (not icomp) (fx= 0 amt)) icomp) ) ) )

(define (version-component-prev comp #!optional (amt 1))
  (and-let* ((vcomp (version-component-lookup comp))
             (prv (vp-prev vcomp)) )
    (do ((amt (check-positive-fixnum 'version-component-prev amt) (fx- amt 1))
         (icomp comp (prv icomp)) )
        ((or (not icomp) (fx= 0 amt)) icomp) ) ) )

;; Pre-defined (builtin) version-components

;when testing always possible target
(define (vp-integer-succ x) (and (fx< x most-positive-fixnum) (fx+ x 1)))
(define (vp-integer-pred x) (and (fx> x 0)                    (fx- x 1)))

;vp-cmp is (* * -> (or -1 0 +1))

;number => + | - | identity
(define vp-integer (make-version-component integer?
                                           (lambda (a b) (signum (- a b)))
                                           string->number number->string
                                           vp-integer-succ vp-integer-pred
                                           identity))

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

;symbol => <error> | <error> | symbol->string
(define vp-symbol (make-version-component symbol?
                                          symbol-compare3
                                          string->symbol symbol->string
                                          ^#f ^#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