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

;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 (string-compare3 s1 s2)
  (let* ((len1 (string-length (check-string 'string-compare3 s1)))
         (len2 (string-length (check-string 'string-compare3 s2)))
         (len (fxmin len1 len2))
         (cmp (string-compare s1 s2 ^-1 ^0 ^+1 0 len 0 len)) )
    (if (fx= 0 cmp) (fx- len1 len2)
        cmp) ) )

(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) )
        `(,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 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))
         (comp comp (nxt comp)) )
        ((or (not comp) (fx= 0 amt)) comp) ) ) )

(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))
         (comp comp (prv comp)) )
        ((or (not comp) (fx= 0 amt)) comp) ) ) )

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