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


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

;;

(define-inline (canon-list-elm x) (if (symbol? x) (symbol->string x) x))

(define-inline (canon-string-elm x) (or (string->number x) x))