;;;; semantic-version-internals.scm  -*- Scheme -*-


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

;;

(define-inline (check-fixnum loc obj) (##sys#check-fixnum obj loc) obj)
(define-inline (check-number loc obj) (##sys#check-number obj loc) obj)

(define-inline (check-range loc i from to) (##sys#check-range i from to loc) i)

;; semantic-version type

(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-inline (vertyp? x) (and (ver? x) (list? (ver-parts x)) (list? (ver-puncs x))))

(define-inline (copy-ver v) (make-ver (list-copy (ver-parts v)) (list-copy (ver-puncs v))))

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

(define-inline (ver-parts? l) (every ver-part? l))
(define-inline (ver-puncs? l) (every ver-punc? l))

;;

(define-inline (badargmsg msg #!optional nam)
  (string-append (or (and nam (->string nam)) "bad argument") " - " msg) )

(define-inline (badargerr loc obj msg #!optional nam)
  (error loc (badargmsg msg nam) obj) )

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

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

;;

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

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

;;

;allows string & list form interchange
(define-inline (canon-compare-elm x) x #;(if (symbol? x) (symbol->string x) x))

;allows string & list form interchange
(define-inline (canon-list-elm x) (if (symbol? x) (symbol->string x) x))

;allows proper comparison
(define-inline (canon-string-elm x) (or (string->number x) x))